! @@name:	reduction.5f
! @@type:	F-free
! @@compilable:	yes
! @@linkable:	yes
! @@expect:	success
MODULE MOD
   INTRINSIC MAX, MIN
END MODULE MOD

PROGRAM REDUCTION4
   USE MOD, MIN=>MAX, MAX=>MIN
   REAL :: R
   R = -HUGE(0.0)

!$OMP PARALLEL DO REDUCTION(MIN: R)     ! still does MAX
   DO I = 1, 1000
      R = MIN(R, SIN(REAL(I)))
   END DO
   PRINT *, R
END PROGRAM REDUCTION4


!##############################################################################
!# ****************************************************************************
!# <name> dom3d_c3d1 </name>
!# ****************************************************************************
!#
!# <purpose>
!# This module contains some auxiliary routines for the 3D domain which is
!# used in the "flow around a hexahedron" benchmark.
!#
!# The domain can be described as the [0, 2.5]x[0, 0.41]x[0, 0.41] hexahedron
!# without the [0.45, 0.55]x[0.15, 0.25]x[0, 0.41] hexahedron.
!#
!# To be (mathematically) more precise:
!#
!#   A := { (x,y,z) \in R^3 | 0 <= x <= 2.5 , 0 <= y, z <= 0.41 }
!#   B := { (x,y,z) \in R^3 | 0.45 < x < 0.55 , 0.15 < y < 0.25
!#                          , 0 <= z <= 0.41 }
!#
!# Then the domain is A \ B.
!#
!# The domain is described by seven boundary regions:
!# 1. The bottom face, i.e. all cells whose Z-coordinate is 0.
!# 2. The front face,  i.e. all cells whose Y-coordinate is 0.
!# 3. The right face,  i.e. all cells whose X-coordinate is 2.5.
!# 4. The back face,   i.e. all cells whose Y-coordinate is 0.41.
!# 5. The left face,   i.e. all cells whose X-coordinate is 0.
!# 6. The top face,    i.e. all cells whose Z-coordinate is 0.41.
!# 7. The obstable,    i.e. all cells whose ...
!#
!# The following routines can be found here:
!#
!#  1.) dom3d_c3d1_calcMeshRegion
!#      -> Creates a mesh region describing a set of specific domain faces.
!#
!#  2.) dom3d_c3d1_HitTest
!#      -> A hit-test routine that is used by dom3d_c3d0_calcMeshRegion,
!#         to identify which cells of the triangulation belong to which
!#         domain face.
!#
!#  3.) dom3d_c3d1_calcParProfile
!#      -> Calculates the parabolic profile for a given domain region.
!#
!# </purpose>
!##############################################################################

module dom3d_c3d1

  use fsystem
  use triangulation
  use meshregion

  implicit none

!<constants>

!<constantblock description="Domain parametrisation">

  ! X-Coordinate ranges
  real(DP), parameter :: DOM3D_C3D1_X_MIN  = 0.0_DP
  real(DP), parameter :: DOM3D_C3D1_X_MAX  = 2.5_DP

  ! Y-Coordinate ranges
  real(DP), parameter :: DOM3D_C3D1_Y_MIN  = 0.0_DP
  real(DP), parameter :: DOM3D_C3D1_Y_MAX  = 0.41_DP

  ! Z-Coordinate ranges
  real(DP), parameter :: DOM3D_C3D1_Z_MIN  = 0.0_DP
  real(DP), parameter :: DOM3D_C3D1_Z_MAX  = 0.41_DP

  ! Obstacle midpoint coordinates
  real(DP), parameter :: DOM3D_C3D1_X_MID  = 0.5_DP
  real(DP), parameter :: DOM3D_C3D1_Y_MID  = 0.2_DP

  ! Edge length of the hexahedral obstacle
  real(DP), parameter :: DOM3D_C3D1_EDGE   = 0.05_DP

!</constantblock>

!<constantblock description="Region identifiers">

  ! Identification flag for the bottom face:
  integer(I32), parameter :: DOM3D_C3D1_REG_BOTTOM   = 2**0

  ! Identification flag for the front face:
  integer(I32), parameter :: DOM3D_C3D1_REG_FRONT    = 2**1

  ! Identification flag for the right face:
  integer(I32), parameter :: DOM3D_C3D1_REG_RIGHT    = 2**2

  ! Identification flag for the back face:
  integer(I32), parameter :: DOM3D_C3D1_REG_BACK     = 2**3

  ! Identification flag for the left face:
  integer(I32), parameter :: DOM3D_C3D1_REG_LEFT     = 2**4

  ! Identification flag for the top face:
  integer(I32), parameter :: DOM3D_C3D1_REG_TOP      = 2**5

  ! Identification flag for the cylinder:
  integer(I32), parameter :: DOM3D_C3D1_REG_OBSTACLE = 2**6

  ! Frequently used: All regions except for the right face.
  ! This combination is often used in (Navier-)Stokes examples where
  ! every region (including the cylinder) is Dirichlet, except for the
  ! right face, which is left Neumann.
  integer(I32), parameter :: DOM3D_C3D1_REG_STOKES = DOM3D_C3D1_REG_BOTTOM &
                     + DOM3D_C3D1_REG_FRONT + DOM3D_C3D1_REG_BACK &
                     + DOM3D_C3D1_REG_LEFT + DOM3D_C3D1_REG_TOP &
                     + DOM3D_C3D1_REG_OBSTACLE

!</constantblock>

!</constants>

interface dom3d_c3d1_calcMeshRegion
  module procedure dom3d_c3d1_calcMeshRegion_C
  module procedure dom3d_c3d1_calcMeshRegion_I
end interface

contains

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

!<subroutine>

  subroutine dom3d_c3d1_calcMeshRegion_C(rmeshRegion,rtriangulation,cregions)

!<description>
  ! This routine calculates a mesh region containing all vertices, edges and
  ! faces that belong to a specific set of domain regions.
!</description>

!<input>
  ! The triangulation on which the mesh region is to be defined.
  ! This trinagulation must represent the "flow around a cylinder" domain.
  type(t_triangulation), target, intent(IN)      :: rtriangulation

  ! A combination of DOM3D_C3D1_REG_XXXX contants defined above specifying
  ! which regions should be in the mesh region.
  integer, intent(IN)                            :: cregions
!<input>

!<output>
  ! The mesh region that is to be created.
  type(t_meshRegion), intent(OUT)                :: rmeshRegion
!<output>

!<subroutine>

  ! Some local variables
  integer :: i
  integer, dimension(7) :: Iregions

    ! First of all, set up the Iregions array:
    do i = 1, 7

      ! If the corresponding bit is set, we'll add the region, otherwise
      ! we will set the corresponding Iregions entry to -1.
      if(iand(cregions, 2**(i-1)) .ne. 0) then
        ! Add the region
        Iregions(i) = i
      else
        ! Ignore the region
        Iregions(i) = -1
      end if

    end do

    ! Create a mesh-region holding all the regions, based on the hit-test
    ! routine below.
    call mshreg_createFromHitTest(rmeshRegion, rtriangulation, &
         MSHREG_IDX_FACE, .true., dom3d_c3d1_HitTest, Iregions)

    ! Now calculate the vertice and edge index arrays in the mesh region
    ! based on the face index array.
    call mshreg_recalcVerticesFromFaces(rmeshRegion)
    call mshreg_recalcEdgesFromFaces(rmeshRegion)

    ! That's it

  end subroutine

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

!<subroutine>

  subroutine dom3d_c3d1_calcMeshRegion_I(rmeshRegion,rtriangulation,Iregions)

!<description>
  ! This routine calculates a mesh region containing all vertices, edges and
  ! faces that belong to a specific set of domain regions.
!</description>

!<input>
  ! The triangulation on which the mesh region is to be defined.
  ! This trinagulation must represent the "flow around a cylinder" domain.
  type(t_triangulation), target, intent(IN)      :: rtriangulation

  ! An array holding the indices of the domain regions which should be in
  ! the mesh region.
  integer, dimension(:), intent(IN)              :: Iregions
!<input>

!<output>
  ! The mesh region that is to be created.
  type(t_meshRegion), intent(OUT)                :: rmeshRegion
!<output>

!<subroutine>

    ! Create a mesh-region holding all the regions, based on the hit-test
    ! routine below.
    call mshreg_createFromHitTest(rmeshRegion, rtriangulation, &
         MSHREG_IDX_FACE, .true., dom3d_c3d1_HitTest, Iregions)

    ! Now calculate the vertice and edge index arrays in the mesh region
    ! based on the face index array.
    call mshreg_recalcVerticesFromFaces(rmeshRegion)
    call mshreg_recalcEdgesFromFaces(rmeshRegion)

    ! That's it

  end subroutine

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

!<subroutine>

  subroutine dom3d_c3d1_HitTest(inumCells,Dcoords,Ihit,rcollection)

  use collection

!<description>
  ! This subroutine is called for hit-testing cells to decide whether a
  ! cell belongs to a specific mesh region or not.
  ! This routine corresponds to the interface defined in
  ! "intf_mshreghittest.inc".
!</description>

!<input>
  ! Number of cells (i.e. vertices,edges,faces,etc.) for which the
  ! hit-test is to be performed.
  integer, intent(IN)                          :: inumCells

  ! Coordinates of the points for which the hit-test is to be performed.
  ! The dimension of the array is at least (1:idim,1:inumCells), where:
  ! -> idim is the dimension of the mesh, i.e. 1 for 1D, 2 for 2D, etc.
  ! -> inumCells is the parameter passed to this routine.
  real(DP), dimension(:,:), intent(IN)         :: Dcoords
!</input>

!<output>
  ! An array that recieves the result of the hit-test.
  ! The dimension of the array is at least (1:inumCells).
  integer, dimension(:), intent(OUT)           :: Ihit
!</output>

!</inputoutput>
  ! OPTIONAL: A collection structure to provide additional information
  ! to the hit-test routine.
  type(t_collection), intent(INOUT), optional  :: rcollection
!</inputoutput>

!</subroutine>

  ! Some local variables
  integer :: i
  real(DP) :: dl

  real(DP), parameter :: tol = 0.0001_DP

    ! Loop through all cells
    do i = 1, inumCells

      ! Bottom face?
      if      ((Dcoords(3,i) - DOM3D_C3D1_Z_MIN) .lt. tol) then
        Ihit(i) = 1

      ! Front face?
      else if ((Dcoords(2,i) - DOM3D_C3D1_Y_MIN) .lt. tol) then
        Ihit(i) = 2

      ! Right face?
      else if ((Dcoords(1,i) - DOM3D_C3D1_X_MAX) .gt. -tol) then
        Ihit(i) = 3

      ! Back face?
      else if ((Dcoords(2,i) - DOM3D_C3D1_Y_MAX) .gt. -tol) then
        Ihit(i) = 4

      ! Left face?
      else if ((Dcoords(1,i) - DOM3D_C3D1_X_MIN) .lt. tol) then
        Ihit(i) = 5

      ! Top face?
      else if ((Dcoords(3,i) - DOM3D_C3D1_Z_MAX) .gt. -tol) then
        Ihit(i) = 6

      ! Hexahedral obstacle?
      else if ((abs(Dcoords(1,i) - DOM3D_C3D1_X_MID) &
                  - DOM3D_C3D1_EDGE .lt. tol) .and. &
               (abs(Dcoords(2,i) - DOM3D_C3D1_Y_MID) &
                  - DOM3D_C3D1_EDGE .lt. tol)) then
        Ihit(i) = 7

      else
        Ihit(i) = 0
      end if

    end do

  end subroutine

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

!<subroutine>

  subroutine dom3d_c3d1_calcParProfile (dvalue, iregion, dx, dy, dz)

!<description>
  ! This routine calculates the parabolic profile for a specified domain
  ! boundary region.
!</description>

!<input>
  ! Specifies the index of the boundary region of which the parabolic profile
  ! is to be calculated.
  integer, intent(IN)                            :: iregion

  ! The coordinates of the point in which the parabolic profile is to be
  ! evaluated.
  real(DP), intent(IN)                           :: dx, dy, dz
!</input>

!<output>
  ! The result of the evaluation of the parabolic profile.
  real(DP), intent(OUT)                          :: dvalue
!</output>

!</subroutine>

  ! Relative X-, Y- and Z-coordinates
  real(DP) :: x,y,z

    ! Convert coordinates to be in range [0,1]
    x = (dx - DOM3D_C3D1_X_MIN) / (DOM3D_C3D1_X_MAX - DOM3D_C3D1_X_MIN)
    y = (dy - DOM3D_C3D1_Y_MIN) / (DOM3D_C3D1_Y_MAX - DOM3D_C3D1_Y_MIN)
    z = (dz - DOM3D_C3D1_Z_MIN) / (DOM3D_C3D1_Z_MAX - DOM3D_C3D1_Z_MIN)

    select case(iregion)
    case (1,6)
      ! X-Y-Profile
      dvalue = 16.0_DP*x*(1.0_DP-x)*y*(1.0_DP-y)

    case (2,4)
      ! X-Z-Profile
      dvalue = 16.0_DP*x*(1.0_DP-x)*z*(1.0_DP-z)

    case (3,5)
      ! Y-Z-Profile
      dvalue = 16.0_DP*y*(1.0_DP-y)*z*(1.0_DP-z)

    case (7)
      ! Z-Profile on the boundary of the hexahedral obstacle
      dvalue = 2.0_DP*z*(1.0_DP-z)

    case DEFAULT
      ! Invalid region
      print *, 'ERROR: dom3d_c3d0_calcParProfile: Invalid region'
      call sys_halt()
    end select

  end subroutine

end module


use SoybeanClass
implicit none

type(Soybean_) :: soy
real(real64),allocatable :: volume(:)

call soy%init(config="Tutorial/obj/soy.json")

volume = soy%getVolumePerElement()

print *, soy%convertDataFormat(scalar=volume,new_format=PF_SOY_OBJECT_WISE)
print *, sum(soy%convertDataFormat(scalar=volume,new_format=PF_SOY_OBJECT_WISE))

end


c
c program yfit
c
      include 'VICMAIN_FOR'
      subroutine main44

      parameter (maxsamp=20000)
      integer*4 ounit,def,count,hist(0:32767)
      integer*4 inunit,status
      real*4 buf(maxsamp),obuf(maxsamp)

c parameters
      call xvparm('PERCENT',percent,count,def,1)
      call xvparm('MAXY',ymax,count,def,1)

c checks
      call xveaction('SA',' ')

c open inputs & outputs
      call xvunit(inunit,'INP',1,status,' ')
      call xvopen(inunit,status,'U_FORMAT','REAL',' ')
      call xvget(inunit,status,'NL',nl,'NS',ns,' ')
      if(ns.gt.maxsamp)then
        call xvmessage('Line length too long',' ')
        call abend
      endif
      call xvunit(ounit,'OUT',1,status,' ')
      call xvopen(ounit,status,'O_FORMAT','REAL','U_FORMAT','REAL',
     +              'OP','WRITE',' ')

c compute max dn
      bigy=0.0
      do line=1,nl
        call xvread(inunit,buf,status,'LINE',line,' ')
        do i=1,ns
          if((buf(i).ge.0.).and.(buf(i).ne.32767.))then
            if(bigy.lt.buf(i))bigy=buf(i)
          endif
        enddo
      enddo
      scale=32767./bigy
      write(msg,*)'max Y value is',bigy
      call xvmessage(msg,' ')

c compute histogram
      m=0
      do i=0,32767
        hist(i)=0
      enddo
      do line=1,nl
        call xvread(inunit,buf,status,'LINE',line,' ')
        do i=1,ns
          if((buf(i).ge.0.).and.(buf(i).ne.32767.))then
            j=nint(buf(i)*scale)
            hist(j)=hist(j)+1
            m=m+1
          endif
        enddo
      enddo
      count=percent*m/100.

c compute percent location
      m=0
      do i=32766,0,-1
        m=m+hist(i)
        if(m.ge.count)then
          location=i
          goto 10
        endif
      enddo
10    continue
      truelocation=location/scale

c compute scaling factor
      scale=ymax/truelocation
      write(msg,*)truelocation,' becomes ',ymax
      call xvmessage(msg,' ')

c process image
      m=0
      do line=1,nl
        call xvread(inunit,buf,status,'LINE',line,' ')
        do i=1,ns
          if(buf(i).eq.32767.)then
            obuf(i)=100.
          else
            obuf(i)=buf(i)*scale
            if(obuf(i).gt.100.)then
              obuf(i)=100.
              m=m+1
            endif
          endif
        enddo
        call xvwrit(ounit,obuf,status,' ')
      enddo

      write(msg,*)m,' pixels saturated to 100'
      call xvmessage(msg,' ')

      end


program test_ewald6

! This test tests direct_sum() for cells with non-zero dipole moment. We use
! ewald_box() as the correct converged results.

use types, only: dp
use constants, only: ang2bohr, kJmol2Ha
use ewald_sums, only: direct_sum, ewald_box, ewald_fft1, min_distance
use utils, only: assert
implicit none

integer :: natom, ntypat
! Various NaCl lattice constants in A
real(dp), parameter :: Llist(5) = [5.6402_dp, 5.5_dp, 4.5_dp, 6.5_dp, 10._dp]
real(dp) :: stress(6)
real(dp) :: eew
real(dp), allocatable :: xred(:, :), fcart(:, :), q(:), &
    forces(:, :)

real(dp) :: L, alpha, E_ewald, E_ewald_fft, E_madelung, E_direct, rel
integer :: i, j, ncut

alpha = 1.8285774522233_dp ! Madelung constant

! Conventional cell:
natom = 8
ntypat = 2
allocate(xred(3, natom), fcart(3, natom), q(natom), forces(3, natom))
! Cl^-
xred(:, 1) = [0._dp, 0._dp, 0._dp]
xred(:, 2) = [1._dp/2, 1._dp/2, 0._dp]
xred(:, 3) = [1._dp/2, 0._dp, 1._dp/2]
xred(:, 4) = [0._dp, 1._dp/2, 1._dp/2]
! Na^+
xred(:, 5) = [1._dp/2, 1._dp/2, 1._dp/2]
xred(:, 6) = [1._dp/2, 0._dp, 0._dp]
xred(:, 7) = [0._dp, 1._dp/2, 0._dp]
xred(:, 8) = [0._dp, 0._dp, 1._dp/2]
q = [-1, -1, -1, -1, 1, 1, 1, 1]*1._dp

! We shift the y-position here, this makes the dipole moment non-zero
xred(2, 2) = 1._dp/4

print *, "half of xred min distance:", min_distance(xred, 1._dp)/2

do i = 1, size(Llist)
    L = Llist(i) * ang2bohr

    call ewald_box(L, xred*L, q, eew, forces, stress)
    E_ewald = eew / (natom/ntypat)

    call ewald_fft1(L, xred*L, q, 128, 0.125_dp*L, eew)
    E_ewald_fft = eew / (natom/ntypat)

    ncut = 20
    call direct_sum(q, xred*L, L, ncut, eew, fcart)
    E_direct = eew / (natom/ntypat)

    E_madelung = -2*alpha/L
    print *, "a =", L/ang2bohr*100, "pm"
    print *, "Madelung:    ", E_madelung / kJmol2Ha, "kJ/mol"
    print *, "Ewald:       ", E_ewald / kJmol2Ha, "kJ/mol"
    print *, "Ewald FFT:   ", E_ewald_fft / kJmol2Ha, "kJ/mol"
    print *, "Direct:      ", E_direct / kJmol2Ha, "kJ/mol"
    print *, "Ewald error:    ", abs(E_ewald - E_madelung), "a.u."
    print *, "Ewald FFT error:", abs(E_ewald_fft - E_madelung), "a.u."
    print *, "Direct error:   ", abs(E_direct - E_madelung), "a.u."
    call assert(abs(E_ewald - E_madelung) < 2e-14_dp)
    call assert(abs(E_ewald_fft - E_madelung) < 1e-10_dp)
    call assert(abs(E_direct - E_madelung) < 1e-8_dp)
    print *, "Forces errors:"
    do j = 1, natom
        rel = sqrt(sum((fcart(:, j)-forces(:, j))**2)/sum(forces(:, j)**2))
        print *, j, rel
        call assert(rel < 1e-5_dp)
    end do
end do
end program


module pmmf_rigid_body_motion
#include <messenger.h>
    use mod_kinds,      only: rk,ik
    use mod_constants,  only: ZERO, HALF, ONE, TWO, THREE, FIVE, EIGHT, PI
    use mod_rigid_body_motion,      only: rigid_body_t0, rigid_body_t1, &
                                 rigid_body_motion_disp_old, rigid_body_motion_disp_new, rigid_body_motion_vel
    use type_prescribed_mesh_motion_function,  only: prescribed_mesh_motion_function_t
    implicit none
    private

    !>  rigid_body_motion mesh (no mesh motion).
    !!
    !!  @author Eric Wolf
    !!  @date  3/15/2017
    !!
    !!
    !-------------------------------------------------------------------------------
    type, extends(prescribed_mesh_motion_function_t), public :: rigid_body_motion_pmmf
        private

    contains

        procedure   :: init
        procedure   :: compute_pos
        procedure   :: compute_vel

    end type rigid_body_motion_pmmf
    !********************************************************************************

contains

    !>
    !!
    !!  @author Eric Wolf
    !!  @date  3/15/2017
    !!
    !-------------------------------------------------------------------------
    subroutine init(self)
        class(rigid_body_motion_pmmf),  intent(inout)  :: self

        !
        ! Set function name
        !
        !self%name = "isentropic vortex  ::  weeeee!"
        call self%set_name("rigid_body_motion")

    end subroutine init
    !*************************************************************************

    !>
    !!
    !!  @author Eric Wolf
    !!  @date  3/15/2017
    !!
    !!
    !-----------------------------------------------------------------------------------------
    function compute_pos(self,time,node) result(val)
        class(rigid_body_motion_pmmf),     intent(inout)   :: self
        real(rk),               intent(in)      :: time
        real(rk),               intent(in)      :: node(3)

        integer(ik)                             :: ivar
        real(rk)                                :: val(3)

        val = node + (rigid_body_t1-time)/(rigid_body_t1-rigid_body_t0)*rigid_body_motion_disp_old + (time-rigid_body_t0)/(rigid_body_t1-rigid_body_t0)*rigid_body_motion_disp_new

    end function compute_pos
    !**********************************************************************************

    !>
    !!
    !!  @author Eric Wolf
    !!  @date  3/15/2017
    !!
    !!
    !-----------------------------------------------------------------------------------------
    function compute_vel(self,time,node) result(val)
        class(rigid_body_motion_pmmf),     intent(inout)   :: self
        real(rk),               intent(in)      :: time
        real(rk),               intent(in)      :: node(3)

        integer(ik)                             :: ivar
        real(rk)                                :: val(3)

        val = rigid_body_motion_vel

    end function compute_vel
    !**********************************************************************************

end module pmmf_rigid_body_motion


! PR 21104.  Make sure that either f() or its caller will allocate
! the array data.  We've decided to make the caller allocate it.
! { dg-do run }
program main
  implicit none
  call test (f ())
contains
  subroutine test (x)
    integer, dimension (10) :: x
    integer :: i
    do i = 1, 10
      if (x (i) .ne. i * 100) call abort
    end do
  end subroutine test

  function f ()
    integer, dimension (10) :: f
    integer :: i
    forall (i = 1:10) f (i) = i * 100
  end function f
end program main


*DECK DHEQR
      SUBROUTINE DHEQR (A, LDA, N, Q, INFO, IJOB)
      INTEGER LDA, N, INFO, IJOB
      DOUBLE PRECISION A(LDA,*), Q(*)
C-----------------------------------------------------------------------
C     This routine performs a QR decomposition of an upper
C     Hessenberg matrix A.  There are two options available:
C
C          (1)  performing a fresh decomposition
C          (2)  updating the QR factors by adding a row and a
C               column to the matrix A.
C-----------------------------------------------------------------------
C     DHEQR decomposes an upper Hessenberg matrix by using Givens
C     rotations.
C
C     On entry
C
C        A       DOUBLE PRECISION(LDA, N)
C                the matrix to be decomposed.
C
C        LDA     INTEGER
C                the leading dimension of the array  A .
C
C        N       INTEGER
C                A is an (N+1) by N Hessenberg matrix.
C
C        IJOB    INTEGER
C                = 1     means that a fresh decomposition of the
C                        matrix A is desired.
C                .ge. 2  means that the current decomposition of A
C                        will be updated by the addition of a row
C                        and a column.
C     On return
C
C        A       the upper triangular matrix R.
C                The factorization can be written Q*A = R, where
C                Q is a product of Givens rotations and R is upper
C                triangular.
C
C        Q       DOUBLE PRECISION(2*N)
C                the factors c and s of each Givens rotation used
C                in decomposing A.
C
C        INFO    INTEGER
C                = 0  normal value.
C                = k  if  A(k,k) .eq. 0.0 .  This is not an error
C                     condition for this subroutine, but it does
C                     indicate that DHELS will divide by zero
C                     if called.
C
C     Modification of LINPACK, by Peter Brown, LLNL.
C     Written 1/13/86.  This version dated 6/20/01.
C-----------------------------------------------------------------------
      INTEGER I, IQ, J, K, KM1, KP1, NM1
      DOUBLE PRECISION C, S, T, T1, T2
C
      IF (IJOB .GT. 1) GO TO 70
C
C A new facorization is desired.
C
C     QR decomposition without pivoting
C
      INFO = 0
      DO 60 K = 1, N
         KM1 = K - 1
         KP1 = K + 1
C
C           Compute kth column of R.
C           First, multiply the kth column of A by the previous
C           k-1 Givens rotations.
C
            IF (KM1 .LT. 1) GO TO 20
            DO 10 J = 1, KM1
              I = 2*(J-1) + 1
              T1 = A(J,K)
              T2 = A(J+1,K)
              C = Q(I)
              S = Q(I+1)
              A(J,K) = C*T1 - S*T2
              A(J+1,K) = S*T1 + C*T2
   10         CONTINUE
C
C           Compute Givens components c and s
C
   20       CONTINUE
            IQ = 2*KM1 + 1
            T1 = A(K,K)
            T2 = A(KP1,K)
            IF (T2 .NE. 0.0D0) GO TO 30
              C = 1.0D0
              S = 0.0D0
              GO TO 50
   30       CONTINUE
            IF (ABS(T2) .LT. ABS(T1)) GO TO 40
              T = T1/T2
              S = -1.0D0/SQRT(1.0D0+T*T)
              C = -S*T
              GO TO 50
   40       CONTINUE
              T = T2/T1
              C = 1.0D0/SQRT(1.0D0+T*T)
              S = -C*T
   50       CONTINUE
            Q(IQ) = C
            Q(IQ+1) = S
            A(K,K) = C*T1 - S*T2
            IF (A(K,K) .EQ. 0.0D0) INFO = K
   60 CONTINUE
      RETURN
C
C The old factorization of A will be updated.  A row and a column
C has been added to the matrix A.
C N by N-1 is now the old size of the matrix.
C
  70  CONTINUE
      NM1 = N - 1
C
C Multiply the new column by the N previous Givens rotations.
C
      DO 100 K = 1,NM1
        I = 2*(K-1) + 1
        T1 = A(K,N)
        T2 = A(K+1,N)
        C = Q(I)
        S = Q(I+1)
        A(K,N) = C*T1 - S*T2
        A(K+1,N) = S*T1 + C*T2
 100    CONTINUE
C
C Complete update of decomposition by forming last Givens rotation,
C and multiplying it times the column vector (A(N,N), A(N+1,N)).
C
      INFO = 0
      T1 = A(N,N)
      T2 = A(N+1,N)
      IF (T2 .NE. 0.0D0) GO TO 110
        C = 1.0D0
        S = 0.0D0
        GO TO 130
 110  CONTINUE
      IF (ABS(T2) .LT. ABS(T1)) GO TO 120
        T = T1/T2
        S = -1.0D0/SQRT(1.0D0+T*T)
        C = -S*T
        GO TO 130
 120  CONTINUE
        T = T2/T1
        C = 1.0D0/SQRT(1.0D0+T*T)
        S = -C*T
 130  CONTINUE
      IQ = 2*N - 1
      Q(IQ) = C
      Q(IQ+1) = S
      A(N,N) = C*T1 - S*T2
      IF (A(N,N) .EQ. 0.0D0) INFO = N
      RETURN
C----------------------- End of Subroutine DHEQR -----------------------
      END


SUBROUTINE linmul_sky(kv,disps,loads,kdiag)
!
! This subroutine forms the product of symmetric matrix stored as
! a skyline and a vector.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::kv(:),disps(0:)
 REAL(iwp),INTENT(OUT)::loads(0:)
 INTEGER,INTENT(IN)::kdiag(:)
 INTEGER::n,i,j,low,lup,k
 REAL(iwp)::x,zero=0.0_iwp
 n=UBOUND(disps,1)
 DO i=1,n
   x=zero
   lup=kdiag(i)
   IF(i==1)low=lup
   IF(i/=1)low=kdiag(i-1)+1
   DO j=low,lup
     x=x+kv(j)*disps(i+j-lup)
   END DO
   loads(i)=x
   IF(i==1)CYCLE
   lup=lup-1
   DO j=low,lup
     k=i+j-lup-1
     loads(k)=loads(k)+kv(j)*disps(i)
   END DO
 END DO
RETURN
END SUBROUTINE linmul_sky


      subroutine mfeout (a,mda,m,n,names,mode)
c     c.l.lawson and r.j.hanson, jet propulsion laboratory, 1973 jun 12
c     to appear in 'solving least squares problems', prentice-hall, 1974
c	   subroutine for matrix output with labeling.
c
c     a( )	   matrix to be output
c		   mda	   first dimension of a array
c		   m	     no. of rows in a matrix
c		   n	     no. of cols in a matrix
c     names()	   array of names.  if names(1) = 1h , the rest
c		   of the names() array will be ignored.
c     mode	   =1	for   4p8f15.0	format	for v matrix.
c		   =2	for   8e15.8  format  for candidate solutions.
c
      dimension    a(mda,01)
      integer names(m),ihead(2)
      logical	notblk
      data  maxcol/8/, iblank/1h /,ihead(1)/4h col/,ihead(2)/4hsoln/
c
      notblk=names(1).ne.iblank
      if (m.le.0.or.n.le.0) return
c
      if (mode.eq.2) go to 10
      write (6,70)
      go to 20
   10 write (6,80)
   20 continue
c
      nblock=n/maxcol
      last=n-nblock*maxcol
      ncol=maxcol
      j1=1
c
c			     main loop starts here
c
   30 if (nblock.gt.0) go to 40
      if (last.le.0) return
      ncol=last
      last=0
c
   40 j2=j1+ncol-1
      write (6,90) (ihead(mode),j,j=j1,j2)
c
	   do 60 i=1,m
	   name=iblank
	   if (notblk) name=names(i)
c
	   if (mode.eq.2) go to 50
	   write (6,100) i,name,(a(i,j),j=j1,j2)
	   go to 60
   50	   write (6,110) i,name,(a(i,j),j=j1,j2)
   60	   continue
c
      j1=j1+maxcol
      nblock=nblock-1
      go to 30
c
   70 format (45h0v-matrix of the singular value decomposition,
     * 8h of a*d./47h (elements of v scaled up by a factor of 10**4))
   80 format (35h0sequence of candidate solutions, x)
   90 format (1h0,11x,8(6x,a4,i4,1x)/1x)
  100 format (1x,i3,1x,a6,1x,4p8f15.0)
  110 format (1x,i3,1x,a6,1x,8e15.8)
      end


! libRQZ
! author: daan. camps@cs.kuleuven.be
! Description:
!   auxilary memory for double multishift
! ___________________________________________________________________
module d_memorymgmt
  use u_parameters
  implicit none
  real(kind=dp), allocatable   :: QM(:,:), ZM(:,:), Q4(:,:), Z4(:,:), &
                                  QW(:,:), ZW(:,:), Ru(:,:), Cu(:,:)
  public d_allocateSwapMMem, d_allocateSwap4Mem, d_allocateAedMem, &
         d_allocateRCMem, d_deallocateSwapMMem, d_deallocateSwap4Mem, &
         d_deallocateAedMem, d_deallocateRCMem, d_getLeadingDim
contains

  subroutine d_allocateSwap4Mem
  ! DESCRIPTION
  !___________________________________________________________________________
  ! Allocates the auxilary arrays for swapping  2x2 poles
  !___________________________________________________________________________
  ! last edit: September 21, 2018
    integer             ::  ERR

    ERR = 0
    if (.not. allocated(Q4)) then
      allocate(Q4(4,4),STAT=ERR)
    end if

    if (.not. allocated(Z4)) then
      allocate(Z4(4,4),STAT=ERR)
    end if

    if (ERR .gt. 0) then
      stop 'FAILED TO ALLOCATE SWAP4 MEMORY'
    end if
  end subroutine

  subroutine d_allocateSwapMMem(m)
  ! DESCRIPTION
  !___________________________________________________________________________
  ! Allocates the auxilary arrays for swapping multiple poles
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! m       integer [IN]
  !           Batch size
  !___________________________________________________________________________
  ! last edit: September 21, 2018
    integer, intent(in) ::  m
    integer             ::  ERR

    ERR = 0
    ! First check if everything is unallocated
    if (allocated(QM)) then
      deallocate(QM)
    end if

    if (allocated(ZM)) then
      deallocate(ZM)
    end if

    if (m .gt. ssth) then
      allocate(QM(m,m),ZM(m,m),STAT=ERR)
    else
      ! In this way they can be used for the single-shift call
      allocate(QM(ssth,ssth),ZM(ssth,ssth),STAT=ERR)
    end if
    if (ERR .gt. 0) then
      stop 'FAILED TO ALLOCATE SWAPM MEMORY'
    end if
  end subroutine

  subroutine d_allocateAedMem(w)
  ! DESCRIPTION
  !___________________________________________________________________________
  ! Allocates the auxilary arrays for aggressive deflation
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! w       integer [IN]
  !           Window size
  !___________________________________________________________________________
  ! last edit: September 21, 2018
    integer, intent(in) ::  w
    integer             ::  ERR

    ERR = 0
    ! First check if everything is unallocated
    if (allocated(QW)) then
      deallocate(QW)
    end if

    if (allocated(ZW)) then
      deallocate(ZW)
    end if

    allocate(QW(w,w),ZW(w,w),STAT=ERR)

    if (ERR .gt. 0) then
      stop 'FAILED TO ALLOCATE AED MEMORY'
    end if
  end subroutine

  subroutine d_allocateRCMem(k,N)
  ! DESCRIPTION
  !___________________________________________________________________________
  ! Allocates the auxilary arrays for row and column updates
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! k       integer [IN]
  !           Update size
  ! N       integer [IN]
  !           Problem size
  !___________________________________________________________________________
  ! last edit: September 21, 2018
    integer, intent(in)   ::  k, N
    integer               ::  ERR

    ERR = 0
    if (allocated(Ru) .and. allocated(Cu)) then
      if (size(Ru,1) .lt. k) then
        deallocate(Cu, Ru,STAT=ERR)
        if (k .gt. ssth) then
          allocate(Cu(N,k),Ru(k,N),STAT=ERR)
        else
          allocate(Cu(N,ssth),Ru(ssth,N),STAT=ERR)
        end if
      else
        ERR = 0
      end if
    elseif (.not. allocated(Ru) .and. .not. allocated(Cu)) then
      if (k .gt. ssth) then
        allocate(Cu(N,k),Ru(k,N),STAT=ERR)
      else
        allocate(Cu(N,ssth),Ru(ssth,N),STAT=ERR)
      end if
    else
      stop 'UNEXPECTED CASE'
    end if

    if (ERR .gt. 0) then
      stop 'FAILED TO ALLOCATE R/C UPDATE MEMORY'
    end if
  end subroutine

  subroutine d_deallocateSwap4Mem
    integer ERR

    ERR = 0
    if (allocated(Q4)) then
      deallocate(Q4,STAT=ERR)
      if (ERR .gt. 0) then
        write(*,*) 'FAILED TO DEALLOCATE Q4 SWAP MEMORY, ERROR CODE', ERR
        stop
      end if
    end if
    if (allocated(Z4)) then
      deallocate(Z4,STAT=ERR)
      if (ERR .gt. 0) then
        write(*,*) 'FAILED TO DEALLOCATE Z4 SWAP MEMORY, ERROR CODE', ERR
        stop
      end if
    end if
  end subroutine

  subroutine d_deallocateSwapMMem
    integer ERR

    ERR = 0
    if (allocated(QM)) then
      deallocate(QM,STAT=ERR)
      if (ERR .gt. 0) then
        write(*,*) 'FAILED TO DEALLOCATE QM SWAP MEMORY, ERROR CODE', ERR
        stop
      end if
    end if
    if (allocated(ZM)) then
      deallocate(ZM,STAT=ERR)
      if (ERR .gt. 0) then
        write(*,*) 'FAILED TO DEALLOCATE ZM SWAP MEMORY, ERROR CODE', ERR
        stop
      end if
    end if
  end subroutine

  subroutine d_deallocateAedMem
    integer ERR

    ERR = 0
    if (allocated(QW)) then
      deallocate(QW, STAT=ERR)
      if (ERR .gt. 0) then
        write(*,*) 'FAILED TO DEALLOCATE QW AED MEMORY, ERROR CODE', ERR
        stop
      end if
    end if
    if (allocated(ZW)) then
      deallocate(ZW, STAT=ERR)
      if (ERR .gt. 0) then
        write(*,*) 'FAILED TO DEALLOCATE ZW AED MEMORY, ERROR CODE', ERR
        stop
      end if
    end if
  end subroutine

  subroutine d_deallocateRCMem
    integer ERR

    ERR = 0
    if (allocated(Ru)) then
      deallocate(Ru, STAT=ERR)
      if (ERR .gt. 0) then
        write(*,*) 'FAILED TO DEALLOCATE Ru MEMORY, ERROR CODE', ERR
        stop
      end if
    end if
    if (allocated(Cu)) then
      deallocate(Cu,STAT=ERR)
      if (ERR .gt. 0) then
        write(*,*) 'FAILED TO DEALLOCATE Cu MEMORY, ERROR CODE', ERR
        stop
      end if
    end if
  end subroutine

  subroutine d_getLeadingDim(LD,M)
  ! DESCRIPTION
  !___________________________________________________________________________
  ! Gets the leading dimension of a 2D array (useful for LAPACK)
  ! ARGUMENTS
  !___________________________________________________________________________
  ! LD      integer [OUT]
  !           Leading dimension
  ! M       double array [IN]
  !           2D array
  !___________________________________________________________________________
  ! last edit: September 25, 2018
    integer, intent(out)          ::  LD
    real(kind=dp), intent(in)     ::  M(:,:)

    LD = size(M,1)
  end subroutine
end module


MODULE invar

! Module to store the AHOT input variables

IMPLICIT NONE

! Title
CHARACTER(80) :: title

! Problem Size Specifications
INTEGER :: lambda, ctype, meth, qdord, qdtyp, nx, ny, ng, nm
REAL*8 :: fweights
REAL*8, DIMENSION(:), ALLOCATABLE :: dx, dy

! Cell materials
INTEGER, DIMENSION(:,:), ALLOCATABLE :: mat

! Boundary Conditions
INTEGER :: lbc, rbc, bbc, tbc

! Iteration Controls
REAL*8 :: err, tolr
INTEGER :: itmx, iall

! Solution check frequency
REAL*8 :: tchk
INTEGER :: ichk

! Extra variables derived from input
INTEGER :: apo, order, ordsq
REAL*8, DIMENSION(:,:), ALLOCATABLE :: ssum

! Angular quadrature input
REAL*8, DIMENSION(:,:), ALLOCATABLE :: ang
REAL*8, DIMENSION(:), ALLOCATABLE :: w

! Cross section input
REAL*8, DIMENSION(:,:), ALLOCATABLE :: sigt
REAL*8, DIMENSION(:,:,:), ALLOCATABLE :: sigs

! Source data
REAL*8, DIMENSION(:,:,:,:,:), ALLOCATABLE :: s

!
! Boundary Source: Added by Sebastian Schunert 02/17/2010
! bsource(nx/y,0:lambda,apo,4,ng)
!
!     __t___
!    |      |
!    l      r
!    |__b___|
!
!
! l(eft) => mu    > 0  ; r(ight) => mu  < 0
! b(ottom) => eta > 0  ; t(op)   => eta < 0
!
REAL*8, DIMENSION(:,:,:,:,:), ALLOCATABLE :: lbsource, rbsource, bbsource,tbsource

! Editing data
INTEGER :: momp, momsum, mompt, qdflx

! Solution methodology
INTEGER :: itmflag

! Print the matrix
INTEGER :: matrix

END MODULE


SUBROUTINE DifferenceSolver(Model, Solver, dt, TransientSimulation)
!------------------------------------------------------------------------------
!******************************************************************************
!
!  Computes the difference between two scalar fields.
!
!  ARGUMENTS:
!
!  TYPE(Model_t) :: Model,
!     INPUT: All model information (mesh, materials, BCs, etc...)
!
!  TYPE(Solver_t) :: Solver
!     INPUT: Linear & nonlinear equation solver options
!
!  REAL(KIND=dp) :: dt,
!     INPUT: Timestep size for time dependent simulations
!
!  LOGICAL :: TransientSimulation
!     INPUT: Steady state or transient simulation
!
!******************************************************************************
  USE DefUtils
  IMPLICIT NONE
!------------------------------------------------------------------------------
  TYPE(Solver_t) :: Solver
  TYPE(Model_t) :: Model
  REAL(KIND=dp) :: dt
  LOGICAL :: TransientSimulation
!------------------------------------------------------------------------------
! Local variables
!------------------------------------------------------------------------------
  TYPE(ValueList_t), POINTER :: SolverParams
  CHARACTER(LEN=MAX_NAME_LEN) :: SenderName, F1name, F2name, MeshName
  TYPE(Variable_t), POINTER :: F1, F2, Difference
  LOGICAL :: Found, AllocationsDone
  INTEGER :: n, t
  TYPE(Element_t), POINTER :: Element
  REAL(KIND=dp), ALLOCATABLE :: F1loc(:), F2loc(:)
  REAL(KIND=dp) :: L2nrm, L2nrmloc, L2nrmf1, L2nrmf1loc, L2nrmf2, L2nrmf2loc
  REAL(KIND=dp) :: H1nrm, H1nrmloc, H1nrmf1, H1nrmf1loc, H1nrmf2, H1nrmf2loc
  SAVE F1loc, F2loc, AllocationsDone
!------------------------------------------------------------------------------
  SenderName = 'DifferenceSolve'

  ! Print mesh name:
  !------------------
  MeshName = Solver % Mesh % Name

  WRITE(Message, *) 'Functions are interpolated using mesh: ', TRIM(MeshName)

  CALL Info(SenderName, Message)

  ! Allocate local storage:
  !-------------------------
  IF(.NOT. AllocationsDone .OR. Solver % Mesh % Changed) THEN
     n = Solver % Mesh % MaxElementDOFs

     IF(AllocationsDone) THEN
        DEALLOCATE(F1loc, F2loc)
     END IF

     ALLOCATE(F1loc(n), F2loc(n))

     AllocationsDone = .TRUE.
  END IF

  ! Fetch first scalar function:
  !------------------------------
  SolverParams => GetSolverParams()

  F1name = GetString(SolverParams, "F1", Found)

  IF(.NOT.Found) THEN
     WRITE(Message, *) 'F1 not found (name unspecified)'
     CALL Fatal(SenderName, Message)
  END IF

  F1 => VariableGet(Solver % Mesh % Variables, F1name)

  IF(.NOT.ASSOCIATED(F1)) THEN
     WRITE(Message, *) 'F1 not found: ', TRIM(F1name)
     CALL Fatal(SenderName, Message)
  ELSE
     WRITE(Message, *) 'F1: "', TRIM(F1name), '" interpolated on ', MeshName
     CALL Info(SenderName, Message)
  END IF

  ! Fetch second scalar function:
  !-------------------------------
  F2name = GetString(SolverParams, "F2", Found)

  IF(.NOT.Found) THEN
     WRITE(Message, *) 'F2 not found (name unspecified)'
     CALL Fatal(SenderName, Message)
  END IF

  F2 => VariableGet(Solver % Mesh % Variables, F2name)

  IF(.NOT.ASSOCIATED(F2)) THEN
     WRITE(Message, *) 'F2 not found: ', TRIM(F2name)
     CALL Fatal(SenderName, Message)
  ELSE
     WRITE(Message, *) 'F2: "', TRIM(F2name), '" interpolated on ', MeshName
     CALL Info(SenderName, Message)
  END IF

  ! Compute the difference:
  !-------------------------
  Difference => Solver % Variable
  Difference % Values = F1 % Values - F2 % Values

  ! Compute norms:
  !----------------
  L2nrm = 0.0d0
  L2nrmf1 = 0.0d0
  L2nrmf2 = 0.0d0

  H1nrm = 0.0d0
  H1nrmf1 = 0.0d0
  H1nrmf2 = 0.0d0

  DO t = 1, GetNofActive()
     Element => GetActiveElement(t)
     n = GetElementNOFNodes(Element)

     CALL GetScalarLocalSolution(F1loc, F1name)
     CALL GetScalarLocalSolution(F2loc, F2name)

     CALL Compute(Element, n, F1loc, F2loc, &
          L2nrmloc, L2nrmf1loc, L2nrmf2loc, &
          H1nrmloc, H1nrmf1loc, H1nrmf2loc)

     L2nrm = L2nrm + L2nrmloc
     L2nrmf1 = L2nrmf1 + L2nrmf1loc
     L2nrmf2 = L2nrmf2 + L2nrmf2loc

     H1nrm = H1nrm + H1nrmloc
     H1nrmf1 = H1nrmf1 + H1nrmf1loc
     H1nrmf2 = H1nrmf2 + H1nrmf2loc
  END DO

  L2nrm = SQRT(L2nrm)
  L2nrmf1 = SQRT(L2nrmf1)
  L2nrmf2 = SQRT(L2nrmf2)

  H1nrm = SQRT(H1nrm)
  H1nrmf1 = SQRT(H1nrmf1)
  H1nrmf2 = SQRT(H1nrmf2)

  WRITE(Message, *) '|| F1 - F2 || =', L2nrm
  CALL Info(SenderName, Message)
  WRITE(Message, *) '|| F1 || =', L2nrmf1
  CALL Info(SenderName, Message)
  WRITE(Message, *) '|| F2 || =', L2nrmf2
  CALL Info(SenderName, Message)

  WRITE(Message, *) '|| grad(F1 - F2) || =', H1nrm
  CALL Info(SenderName, Message)
  WRITE(Message, *) '|| grad F1 || =', H1nrmf1
  CALL Info(SenderName, Message)
  WRITE(Message, *) '|| grad F2 || =', H1nrmf2
  CALL Info(SenderName, Message)

CONTAINS

  SUBROUTINE Compute(Element, n, F1, F2, &
       L2nrm, L2nrmf1, L2nrmf2, &
       H1nrm, H1nrmf1, H1nrmf2)

    TYPE(Element_t), POINTER :: Element
    INTEGER :: n
    REAL(KIND=dp) :: F1(:), F2(:)
    REAL(KIND=dp) :: L2nrm, L2nrmf1, L2nrmf2
    REAL(KIND=dp) :: H1nrm, H1nrmf1, H1nrmf2

    TYPE(GaussIntegrationPoints_t) :: IP
    REAL(KIND=dp) :: detJ, Basis(n), dBasisdx(n, 3)
    REAL(KIND=dp) :: F1atIP, F2atIP
    REAL(KIND=dp) :: gradF1atIP(n), gradF2atIP(n)
    INTEGER :: t, i
    LOGICAL :: stat
    TYPE(Nodes_t) :: Nodes
    SAVE Nodes

    CALL GetElementNodes(Nodes)

    IP = GaussPoints(Element)

    L2nrm = 0.0d0
    L2nrmf1 = 0.0d0
    L2nrmf2 = 0.0d0

    H1nrm = 0.0d0
    H1nrmf1 = 0.0d0
    H1nrmf2 = 0.0d0

    DO t = 1, IP % n
       stat = ElementInfo(Element, Nodes, &
            IP % U(t), IP % V(t), IP % W(t), &
            detJ, Basis, dBasisdx)

       F1atIP = SUM( F1(1:n) * Basis(1:n) )
       F2atIP = SUM( F2(1:n) * Basis(1:n) )

       gradF1atIP(1:3) = MATMUL(TRANSPOSE(dBasisdx(1:n,1:3)), F1(1:n) )
       gradF2atIP(1:3) = MATMUL(TRANSPOSE(dBasisdx(1:n,1:3)), F2(1:n) )

       L2nrm = L2nrm + (F1atIP - F2atIP)**2 * IP % s(t) * detJ
       L2nrmf1 = L2nrmf1 + F1atIP**2 * IP % s(t) * detJ
       L2nrmf2 = L2nrmf2 + F2atIP**2 * IP % s(t) * detJ

       DO i = 1, 3
          H1nrm = H1nrm + (gradF1atIP(i) - gradF2atIP(i))**2 * IP % s(t) * detJ
          H1nrmf1 = H1nrmf1 + gradF1atIP(i)**2 * IP % s(t) * detJ
          H1nrmf2 = H1nrmf2 + gradF2atIP(i)**2 * IP % s(t) * detJ
       END DO

    END DO

  END SUBROUTINE Compute

END SUBROUTINE DifferenceSolver


program case03
    implicit none

    ! local variable declaration
    integer :: marks
    integer, parameter :: a = 1, b = 2
    marks = 94

    select case (marks)

       case ((40 + b):)
          print *, "Pass!"

       case (:(39 - a))
          print *, "Failed!"

       case default
          print*, "Invalid marks"

    end select
    print*, "Your marks are ", marks

    marks = -1

    select case (marks)

      case ((40 + b):)
         print *, "Pass!"

      case (0:(39 - a))
         print *, "Failed!"

      case default
         print*, "Invalid marks"

   end select
   print*, "Your marks are ", marks

end program


module bvp_solvers

contains

subroutine solve_bvp_direct(x, u_left, u_right, u)
    use problem, only: f
    implicit none
    real(kind=8), intent(in) :: x(0:)
    real(kind=8), intent(in) :: u_left, u_right
    real(kind=8), intent(out) :: u(0:)

    ! decleare local variables and continue writing this code...

end subroutine solve_bvp_direct

end module bvp_solvers


        subroutine idz_findrank0(lra,eps,m,n,matveca,p1,p2,p3,p4,
     1                           krank,ra,ier,x,y,scal)
c
c       routine idz_findrank serves as a memory wrapper
c       for the present routine. (Please see routine idz_findrank
c       for further documentation.)
c
        implicit none
        integer m,n,krank,ifrescal,k,lra,ier,m2
        real*8 eps,enorm
        complex*16 x(m),ra(n,2,*),p1,p2,p3,p4,scal(n+1),y(n),residual
        external matveca
c
c
        ier = 0
c
c
        krank = 0
c
c
c       Loop until the relative residual is greater than eps,
c       or krank = m or krank = n.
c
 1000   continue
c
c
          if(lra .lt. n*2*(krank+1)) then
            ier = -1000
            return
          endif
c
c
c         Apply the adjoint of a to a random vector.
c
          m2 = m*2
          call id_srand(m2,x)
          call matveca(m,x,n,ra(1,1,krank+1),p1,p2,p3,p4)
c
          do k = 1,n
            y(k) = ra(k,1,krank+1)
          enddo ! k
c
c
          if(krank .eq. 0) then
c
c           Compute the Euclidean norm of y.
c
            enorm = 0
c
            do k = 1,n
              enorm = enorm + y(k)*conjg(y(k))
            enddo ! k
c
            enorm = sqrt(enorm)
c
          endif ! krank .eq. 0
c
c
          if(krank .gt. 0) then
c
c           Apply the previous Householder transformations to y.
c
            ifrescal = 0
c
            do k = 1,krank
              call idz_houseapp(n-k+1,ra(1,2,k),y(k),
     1                          ifrescal,scal(k),y(k))
            enddo ! k
c
          endif ! krank .gt. 0
c
c
c         Compute the Householder vector associated with y.
c
          call idz_house(n-krank,y(krank+1),
     1                   residual,ra(1,2,krank+1),scal(krank+1))
c
c
          krank = krank+1
c
c
        if(abs(residual) .gt. eps*enorm
     1   .and. krank .lt. m .and. krank .lt. n)
     2   goto 1000
c
c
c       Delete the Householder vectors from the array ra.
c
        call idz_crunch(n,krank,ra)
c
c
        return
        end
c
c
c
c


MODULE m_stern
  !     **************************************************************
  !     returns star of recipocal space vector g
  !     called by force_a8 - APW+LO package
  !     *************************************************************
CONTAINS
  SUBROUTINE stern(sym,cell,g, nst,stg,taup,gl,rstg)

    USE m_constants, ONLY : tpi_const
    USE m_types
    IMPLICIT NONE
    TYPE(t_sym),INTENT(IN)   :: sym
    TYPE(t_cell),INTENT(IN)   :: cell
    !     ..
    !     .. Arguments
    INTEGER, INTENT (IN)  :: g(3)

    INTEGER, INTENT (OUT) :: nst,stg(3,sym%nop)
    REAL,    INTENT (OUT) :: gl,rstg(3,sym%nop)
    COMPLEX, INTENT (OUT) :: taup(sym%nop)
    !     ..
    !     .. Local Variables
    INTEGER               :: i,m,j,k,l,ind(sym%nop)
    REAL                  :: tk,s,rg(3)

    ind(1:sym%nop)  = 0
    taup(1:sym%nop) = 0.0
    nst = 0

    rg(:) = REAL( g(:) )
    gl = SQRT( DOT_PRODUCT(rg,MATMUL(rg,cell%bbmat)))

    i_loop:DO i = 1,sym%nop
       tk=0.
       DO j=1,3
          tk=tk+sym%tau(j,i)*g(j)*tpi_const
          k=0
          DO l=1,3
             k=sym%mrot(l,j,i)*g(l)+k
          ENDDO
          stg(j,i)=k
       ENDDO
       IF (nst.NE.0) THEN
          DO m = 1,nst
               IF (ALL(stg(:,m)==stg(:,i))) THEN
                  ind(m)=ind(m)+1
                  taup(m)=taup(m) + CMPLX(COS(tk),SIN(tk))
                  CYCLE i_loop
               ENDIF
            ENDDO
         ENDIF
         nst=nst+1
         stg(:,nst)=stg(:,i)
         DO j = 1,3
            rstg(j,nst) = DOT_PRODUCT(stg(:,nst),cell%bmat(:,j))
         ENDDO
         ind(nst)  = 1
         taup(nst) = CMPLX(COS(tk),SIN(tk))
      ENDDO i_loop

      taup(:nst)=taup(:nst)/ind(:nst)

      RETURN
   END SUBROUTINE stern
END MODULE m_stern


      program prog
      integer root_size
      parameter(root_size=3)
      parameter(nums_size=2*root_size)
      dimension nums(nums_size)
      call sub(nums)
      write(6, *) nums
      end

      subroutine sub(nums)
      integer root_size
      parameter(root_size=3)
      parameter(nums_size=2*root_size)
      dimension nums(nums_size)
      do i=1,nums_size
        nums(i) = 13+i
      enddo
      end


program test_daykm
  use simsphere_mod, only: hgt, ustar, mol, km, ntrp, deltaz, zi, zk, eq
  use mod_testing, only: assert, initialize_tests, report_tests
  use, intrinsic :: ieee_arithmetic
  implicit none

  ! mod_testing setup
  logical, dimension(:), allocatable :: tests
  logical :: test_failed
  integer :: n, ntests

  real :: arg1

  ! Two cases: HGT - ZA == 0 and HGT - ZA /= 0
  ! Expected results
  real, parameter, dimension(50) :: km_I_exp = 0.0
  real, parameter, dimension(50) :: km_II_exp = (/-253.990555,50889.9414,  &
                                                  76076.1875,76076.1875,   &
                                                  76076.1875,76076.1875,   &
                                                  76076.1875,76076.1875,   &
                                                  76076.1875,76076.1875,   &
                                                  0.0,0.0,0.0,0.0,0.0,     &
                                                  0.0,0.0,0.0,0.0,0.0,     &
                                                  0.0,0.0,0.0,0.0,0.0,     &
                                                  0.0,0.0,0.0,0.0,0.0,     &
                                                  0.0,0.0,0.0,0.0,0.0,     &
                                                  0.0,0.0,0.0,0.0,0.0,     &
                                                  0.0,0.0,0.0,0.0,0.0,     &
                                                  0.0,0.0,0.0,0.0,0.0/)
  real, parameter, dimension(50) :: zk_I_exp = 0.0
  real, parameter, dimension(50) :: zk_II_exp = (/5.0,4.5,4.5,4.5,4.5,     &
                                                  4.5,4.5,4.5,4.5,4.5,     &
                                                  4.5,0.0,0.0,0.0,0.0,     &
                                                  0.0,0.0,0.0,0.0,0.0,     &
                                                  0.0,0.0,0.0,0.0,0.0,     &
                                                  0.0,0.0,0.0,0.0,0.0,     &
                                                  0.0,0.0,0.0,0.0,0.0,     &
                                                  0.0,0.0,0.0,0.0,0.0,     &
                                                  0.0,0.0,0.0,0.0,0.0,     &
                                                  0.0,0.0,0.0,0.0,0.0/)

  n = 1
  ntests = 6
  call initialize_tests(tests,ntests)

  if (ieee_support_rounding(IEEE_NEAREST)) then
    call ieee_set_rounding_mode(IEEE_NEAREST)
  end if

  hgt = 50.0
  ustar = 3.0
  km = 0.0
  ntrp = 10
  deltaz = 1.0
  zi = 5.0
  zk = 0.0
  mol = 1.0

  ! Case I (thick == 1, hgt == za)
  arg1 = 1.0
  call daykm(arg1)
  tests(n) = assert(eq(km,km_I_exp), 'daykm km case I')
  n = n + 1
  tests(n) = assert(eq(zk,zk_I_exp), 'daykm zk case I')
  n = n + 1

  ! Case II (thick == 1, hgt /= za)
  arg1 = 1.0
  km = 0.0
  zk = 0.0
  hgt = 60.0
  call daykm(arg1)
  tests(n) = assert(eq(km,km_II_exp), 'daykm km case II')
  n = n + 1
  tests(n) = assert(eq(zk,zk_II_exp), 'daykm zk case II')
  n = n + 1

  ! Case III (thick = 0)
  arg1 = 0.0
  call daykm(arg1)
  tests(n) = assert(eq(km,km_II_exp), 'daykm km case III')
  n = n + 1
  tests(n) = assert(eq(zk,zk_II_exp), 'daykm zk case III')
  n = n + 1

  test_failed = .false.
  call report_tests(tests,test_failed)
  if (test_failed) stop 1

end program test_daykm


!==============================================================================!
  subroutine Probe_1d_Cells_Nodes(grid)
!------------------------------------------------------------------------------!
!   This subroutine finds the coordinate of cell's nodes in non-homogeneous    !
!   direction and write them in file called "name.1d"                          !
!------------------------------------------------------------------------------!
  use File_Mod
  use Math_Mod
  use Grid_Mod
  use Sort_Mod
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Grid_Type) :: grid
!-----------------------------------[Locals]-----------------------------------!
  integer           :: n_prob, p, c, n, fu
  real              :: zp(16384)
  character(len=80) :: name_prob
  character(len=80) :: answer
  logical           :: isit
!==============================================================================!

  print *, '#==========================================='
  print *, '# Creating 1d file with the node '
  print *, '# coordinates in non-homogeneous directions '
  print *, '#-------------------------------------------'
  print *, '# Insert non-homogeneous direction '
  print *, '# (x, y, z, rx, ry, rz or skip)'
  print *, '# -------------------------------------------'
  read(*,*) answer
  call To_Upper_Case(answer)
  if(answer .eq. 'SKIP') return

  n_prob = 0
  zp(:)  = 0.0

  !-----------------------------!
  !   Browse through all cells  !
  !-----------------------------!
  do c = -grid % n_bnd_cells, grid % n_cells
    do n = 1, grid % cells_n_nodes(c)

      ! Try to find the cell among the probes
      do p=1, n_prob
        if(answer .eq. 'X') then
          if( Math_Mod_Approx_Real(  &
              grid % xn(grid % cells_n(n,c)), zp(p)) ) go to 1
        else if(answer .eq. 'Y') then
          if( Math_Mod_Approx_Real(  &
              grid % yn(grid % cells_n(n,c)), zp(p)) ) go to 1
        else if(answer .eq. 'Z') then
          if( Math_Mod_Approx_Real(  &
              grid % zn(grid % cells_n(n,c)), zp(p)) ) go to 1
        else if(answer .eq. 'RX') then
          if( Math_Mod_Approx_Real(                              &
              sqrt(grid % zn(grid % cells_n(n,c))**2 +           &
                   grid % yn(grid % cells_n(n,c))**2), zp(p)) )  &
            go to 1
        else if(answer .eq. 'RY') then
          if( Math_Mod_Approx_Real(                              &
              sqrt(grid % xn(grid % cells_n(n,c))**2 +           &
                   grid % zn(grid % cells_n(n,c))**2), zp(p)) )  &
            go to 1
        else if(answer .eq. 'RZ') then
          if( Math_Mod_Approx_Real(                              &
              sqrt(grid % xn(grid % cells_n(n,c))**2 +           &
                   grid % yn(grid % cells_n(n,c))**2), zp(p)) )  &
            go to 1
        end if
      end do

      ! Couldn't find a cell among the probes, add a new one
      n_prob = n_prob + 1
      if(answer .eq. 'X') zp(n_prob) = grid % xn(grid % cells_n(n,c))
      if(answer .eq. 'Y') zp(n_prob) = grid % yn(grid % cells_n(n,c))
      if(answer .eq. 'Z') zp(n_prob) = grid % zn(grid % cells_n(n,c))

      if(answer .eq. 'RX') zp(n_prob) =                                  &
                           sqrt(grid % zn(grid % cells_n(n,c))**2 +      &
                                grid % yn(grid % cells_n(n,c))**2)
      if(answer .eq. 'RY') zp(n_prob) =                                  &
                           sqrt(grid % xn(grid % cells_n(n,c))**2 +      &
                                grid % zn(grid % cells_n(n,c))**2)
      if(answer .eq. 'RZ') zp(n_prob) =                                  &
                           sqrt(grid % xn(grid % cells_n(n,c))**2 +      &
                                grid % yn(grid % cells_n(n,c))**2)

      if(n_prob .eq. 16384) then
        print *, '# Probe 1d: Not a 1d (channel flow) problem.'
        isit = .false.
        return
      end if
    end do
1 end do

  isit = .true.

  !--------------------!
  !   Create 1d file   !
  !--------------------!
  call File_Mod_Set_Name(name_prob, extension='.1d')
  call File_Mod_Open_File_For_Writing(name_prob, fu)

  ! Write the number of probes
  write(fu,'(i8)') n_prob

  call Sort_Mod_Real(zp(1:n_prob))

  ! Write the probe coordinates out
  do p=1, n_prob
    write(fu,'(i8,1e17.8)') p, zp(p)
  end do

  close(fu)

  end subroutine


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! z_upr1fact_qr
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine computes the Schur decomposition of a factored unitary
! plus rank one (upr1fact) matrix. Such a matrix is stored as 3 sequences
! of rotations and a unimodular diagonal matrix.
!
! The extended hessenberg matrix H = Q(P)*D*C*B
!
! The columns of V are the right Schur vectors.
! Namely, V*HV is upper-triangular.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  VEC             LOGICAL
!                    .TRUE.: compute schurvector
!                    .FALSE.: no schurvectors
!
!  ID              LOGICAL
!                    .TRUE.: initialize V and W to I
!                    .FALSE.: assume V and W already initialized
!
!  FUN             LOGICAL FUNCTION FUN(N,P)
!                    takes integer N and logical array P of
!                    dimension N-2 and outputs a logical
!
!  N               INTEGER
!                    dimension of matrix
!
!  P               LOGICAL array of dimension (N-2)
!                    array of position flags for Q
!
!  Q               REAL(8) array of dimension (3*(N-1))
!                    array of generators for first sequence of rotations
!
!  D               REAL(8) arrays of dimension (2*N)
!                    array of generators for complex diagonal matrix
!                    in the upper-triangular factor
!
!  C,B             REAL(8) arrays of dimension (3*N)
!                    array of generators for upper-triangular part
!
!  M               INTEGER
!                    leading dimension of V
!
! OUTPUT VARIABLES:
!
!  V              COMPLEX(8) array of dimension (M,N)
!                   right schur vectors
!
!  ITS            INTEGER array of dimension (N-1)
!                   Contains the number of iterations per deflation
!
!  INFO           INTEGER
!                   INFO = 2 implies no convergence
!                   INFO = 1 random seed initialization failed
!                   INFO = 0 implies successful computation
!                   INFO = -1 implies N, Q, D, C, or B is invalid
!                   INFO = -14 implies V is invalid
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine z_upr1fact_qr(VEC,ID,FUN,N,P,Q,D,C,B,M,V,ITS,INFO)

  implicit none

  ! input variables
  logical, intent(in) :: VEC, ID
  integer, intent(in) :: N, M
  logical, intent(inout) :: P(N-2)
  real(8), intent(inout) :: Q(3*(N-1)), D(2*N), C(3*N), B(3*N)
  complex(8), intent(inout) :: V(M,N)
  integer, intent(inout) :: INFO, ITS(N-1)
  interface
    function FUN(m,flags)
      logical :: FUN
      integer, intent(in) :: m
      logical, dimension(m-2), intent(in) :: flags
    end function FUN
  end interface

  ! compute variables
  logical :: flg
  integer :: ii, kk
  integer :: STR, STP, ZERO, ITMAX, ITCNT

  ! initialize info
  INFO = 0

  ! initialize random seed
  !call u_randomseed_initialize(INFO)
  if (INFO.NE.0) then
    ! print error message in debug mode
    if (DEBUG) then
      call u_infocode_check(__FILE__,__LINE__, &
           "Failed to initialize random seed",INFO,INFO)
    end if
    INFO = 1
    return
  end if

  ! check factorization
  call z_upr1fact_factorcheck(N,Q,D,C,B,INFO)
  if (INFO.NE.0) then
    ! print error message in debug mode
    if (DEBUG) then
      call u_infocode_check(__FILE__,__LINE__, &
           "N, Q, D, C or B is invalid",INFO,INFO)
    end if
    INFO = -1
    return
  end if

  ! check V
  if (VEC.AND..NOT.ID) then
    call z_2Darray_check(N,N,V,flg)
    if (.NOT.flg) then
      INFO = -14
      ! print error message in debug mode
      if (DEBUG) then
        call u_infocode_check(__FILE__,__LINE__,"V is invalid",INFO,INFO)
      end if
      return
    end if
  end if

  ! initialize storage
  ITS = 0

  if (VEC.AND.ID) then
    V = cmplx(0d0,0d0,kind=8)
    do ii=1,n
      V(ii,ii) = cmplx(1d0,0d0,kind=8)
    end do
  end if

  ! initialize indices
  STR = 1
  STP = N-1
  ZERO = 0
  ITMAX = 20*N
  ITCNT = 0

  ! iteration loop
  do kk=1,ITMAX

    ! check for completion
    if(STP <= 0)then
      exit
    end if

!print*,""
!print*,"Inside QR"
!print*,"Q"
!do ii=1,N-1
!print*,Q(3*ii-2:3*ii)
!end do
!print*,""
!write(*,*) "Press enter to continue"
!read(*,*)

    ! check for deflation
    call z_upr1fact_deflationcheck(VEC,STP-STR+2,P(STR:(STP-1)), &
         Q((3*STR-2):(3*STP)),D((2*STR-1):(2*STP+2)), &
         C((3*STR-2):(3*STP+3)),B((3*STR-2):(3*STP+3)),M,V(:,STR:STP+1),ZERO)

    ! if 1x1 block remove and check again
    if(STP == (STR+ZERO-1))then

      ! update indices
      ITS(STR+ZERO-1) = ITCNT
      ITCNT = 0
      STP = STP - 1
      ZERO = 0
      STR = 1

    ! if greater than 1x1 chase a bulge
    else

      ! check STR
      if (ZERO.GT.0) then
         STR = STR + ZERO
         ZERO = 0
         ITS(STR+ZERO-1) = ITCNT
         ITCNT = 0
      end if

      ! perform singleshift iteration
      call z_upr1fact_singlestep(VEC,FUN,STP-STR+2,P(STR:(STP-1)) &
      ,Q((3*STR-2):(3*STP)),D((2*STR-1):(2*STP+2)) &
      ,C((3*STR-2):(3*STP+3)),B((3*STR-2):(3*STP+3)) &
      ,M,V(:,STR:(STP+1)),ITCNT)

      ! update indices
      if (ITCNT.EQ.-1) then
        ITCNT = 1
      else
        ITCNT = ITCNT + 1
      end if

    end if

    ! if ITMAX hit
    if (kk == ITMAX) then
      INFO = 1
      ITS(STR+STP-1) = ITCNT
    end if

  end do

end subroutine z_upr1fact_qr


! rk4_integrator.f90
!
!>  Module containing the fourth-order Runge-Kutta (RK4) integration routines.
!
!> @copyright
!> 2015-2020 Lesley De Cruz & Jonathan Demaeyer.
!> See LICENSE.txt for license information.
!
!---------------------------------------------------------------------------!
!
!
!---------------------------------------------------------------------------

MODULE rk4_integrator
  USE model_def
  USE integrator_def
  IMPLICIT NONE

  PRIVATE

  !> Class for the fourth-order Runge-Kutta (RK4) integrator object.
  TYPE, EXTENDS(Integrator), PUBLIC :: RK4Integrator
    REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: buf_y1 !< Buffer to hold the intermediate position
    REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: buf_kA !< Buffer to hold tendencies at the initial position
    REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: buf_kB !< Buffer to hold tendencies at the intermediate position
  CONTAINS
    PROCEDURE :: init
    PROCEDURE :: step
    PROCEDURE :: clean
  END TYPE RK4Integrator

CONTAINS

  !> Routine to initialise the integration buffers.
  !> @param[in,out] integr Integrator object to initialize.
  !> @param[in] imodel Model object to initialize the integrator with.
  SUBROUTINE init(integr, imodel)
    CLASS(RK4Integrator), INTENT(INOUT) :: integr
    CLASS(Model), INTENT(IN), TARGET :: imodel
    INTEGER :: AllocStat
    IF (.NOT.imodel%initialized) THEN
      PRINT*, 'Model not yet initialized, impossible to associate an integrator to an empty model!'
      RETURN
    END IF

    integr%pmodel => imodel
    integr%dt => imodel%model_configuration%integration%dt
    integr%ndim => imodel%model_configuration%modes%ndim

    ALLOCATE(integr%buf_y1(0:integr%ndim) ,STAT=AllocStat)
    IF (AllocStat /= 0) THEN
      PRINT*, "*** rk4integrator%init: Problem with allocation! ***"
      STOP "Exiting ..."
    END IF
    ALLOCATE(integr%buf_kA(0:integr%ndim) ,STAT=AllocStat)
    IF (AllocStat /= 0) THEN
      PRINT*, "*** rk4integrator%init: Problem with allocation! ***"
      STOP "Exiting ..."
    END IF
    ALLOCATE(integr%buf_kB(0:integr%ndim) ,STAT=AllocStat)
    IF (AllocStat /= 0) THEN
      PRINT*, "*** rk4integrator%init: Problem with allocation! ***"
      STOP "Exiting ..."
    END IF

  END SUBROUTINE init

  !> Routine to perform an integration step (RK4 algorithm). The incremented time is returned.
  !> @param[in,out] integr Integrator object to perform the step with.
  !> @param[in] y Initial point.
  !> @param[in] t Actual integration time
  !> @param[out] res Final point after the step.
  SUBROUTINE step(integr, y,t,res)
    CLASS(RK4Integrator), INTENT(INOUT) :: integr
    REAL(KIND=8), DIMENSION(0:integr%ndim), INTENT(IN) :: y
    REAL(KIND=8), INTENT(INOUT) :: t
    REAL(KIND=8), DIMENSION(0:integr%ndim), INTENT(OUT) :: res

    CALL integr%pmodel%tendencies(t,y,integr%buf_kA)
    integr%buf_y1 = y + 0.5*integr%dt*integr%buf_kA

    CALL integr%pmodel%tendencies(t+0.5*integr%dt,integr%buf_y1,integr%buf_kB)
    integr%buf_y1 = y + 0.5*integr%dt*integr%buf_kB
    integr%buf_kA = integr%buf_kA + 2*integr%buf_kB

    CALL integr%pmodel%tendencies(t+0.5*integr%dt,integr%buf_y1,integr%buf_kB)
    integr%buf_y1 = y + integr%dt*integr%buf_kB
    integr%buf_kA = integr%buf_kA + 2*integr%buf_kB

    CALL integr%pmodel%tendencies(t+integr%dt,integr%buf_y1,integr%buf_kB)
    integr%buf_kA = integr%buf_kA + integr%buf_kB

    t=t+integr%dt
    res=y+integr%buf_kA*integr%dt/6
  END SUBROUTINE step

  !> Routine to clean the integrator
  !> @param[in,out] integr Integrator object to clean.
  SUBROUTINE clean(integr)
      CLASS(RK4Integrator), INTENT(INOUT) :: integr

      IF (allocated(integr%buf_y1)) DEALLOCATE(integr%buf_y1)
      IF (allocated(integr%buf_kA)) DEALLOCATE(integr%buf_kA)
      IF (allocated(integr%buf_kB)) DEALLOCATE(integr%buf_kB)

  END SUBROUTINE clean

END MODULE rk4_integrator


*DECK TEVLS
      SUBROUTINE TEVLS (N, D, E2, IERR)
C***BEGIN PROLOGUE  TEVLS
C***SUBSIDIARY
C***PURPOSE  Subsidiary to BLKTRI
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (TEVLS-S)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     This subroutine finds the eigenvalues of a symmetric tridiagonal
C     matrix by the rational QL method.
C
C     On Input-
C
C        N is the order of the matrix,
C
C        D contains the diagonal elements of the input matrix,
C
C        E2 contains the subdiagonal elements of the input matrix
C           in its last N-1 positions.  E2(1) is arbitrary.
C
C      On Output-
C
C        D contains the eigenvalues in ascending order.  If an
C          error exit is made, the eigenvalues are correct and
C          ordered for indices 1,2,...IERR-1, but may not be
C          the smallest eigenvalues,
C
C        E2 has been destroyed,
C
C        IERR is set to
C          ZERO       for normal return,
C          J          if the J-th eigenvalue has not been
C                     determined after 30 iterations.
C
C***SEE ALSO  BLKTRI
C***REFERENCES  C. H. Reinsch, Eigenvalues of a real, symmetric, tri-
C                 diagonal matrix, Algorithm 464, Communications of the
C                 ACM 16, 11 (November 1973), pp. 689.
C***ROUTINES CALLED  (NONE)
C***COMMON BLOCKS    CBLKT
C***REVISION HISTORY  (YYMMDD)
C   801001  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900402  Added TYPE section.  (WRB)
C   920528  DESCRIPTION revised and REFERENCES section added.  (WRB)
C***END PROLOGUE  TEVLS
C
      INTEGER         I          ,J          ,L          ,M          ,
     1                N          ,II         ,L1         ,MML        ,
     2                IERR
      REAL            D(*)       ,E2(*)
      REAL            B          ,C          ,F          ,G          ,
     1                H          ,P          ,R          ,S          ,
     2                MACHEP
C
      COMMON /CBLKT/  NPP        ,K          ,MACHEP     ,CNV        ,
     1                NM         ,NCMPLX     ,IK
C***FIRST EXECUTABLE STATEMENT  TEVLS
      IERR = 0
      IF (N .EQ. 1) GO TO 115
C
      DO 101 I=2,N
         E2(I-1) = E2(I)*E2(I)
  101 CONTINUE
C
      F = 0.0
      B = 0.0
      E2(N) = 0.0
C
      DO 112 L=1,N
         J = 0
         H = MACHEP*(ABS(D(L))+SQRT(E2(L)))
         IF (B .GT. H) GO TO 102
         B = H
         C = B*B
C
C     ********** LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT **********
C
  102    DO 103 M=L,N
            IF (E2(M) .LE. C) GO TO 104
C
C     ********** E2(N) IS ALWAYS ZERO, SO THERE IS NO EXIT
C                THROUGH THE BOTTOM OF THE LOOP **********
C
  103    CONTINUE
C
  104    IF (M .EQ. L) GO TO 108
  105    IF (J .EQ. 30) GO TO 114
         J = J+1
C
C     ********** FORM SHIFT **********
C
         L1 = L+1
         S = SQRT(E2(L))
         G = D(L)
         P = (D(L1)-G)/(2.0*S)
         R = SQRT(P*P+1.0)
         D(L) = S/(P+SIGN(R,P))
         H = G-D(L)
C
         DO 106 I=L1,N
            D(I) = D(I)-H
  106    CONTINUE
C
         F = F+H
C
C     ********** RATIONAL QL TRANSFORMATION **********
C
         G = D(M)
         IF (G .EQ. 0.0) G = B
         H = G
         S = 0.0
         MML = M-L
C
C     ********** FOR I=M-1 STEP -1 UNTIL L DO -- **********
C
         DO 107 II=1,MML
            I = M-II
            P = G*H
            R = P+E2(I)
            E2(I+1) = S*R
            S = E2(I)/R
            D(I+1) = H+S*(H+D(I))
            G = D(I)-E2(I)/G
            IF (G .EQ. 0.0) G = B
            H = G*P/R
  107    CONTINUE
C
         E2(L) = S*G
         D(L) = H
C
C     ********** GUARD AGAINST UNDERFLOWED H **********
C
         IF (H .EQ. 0.0) GO TO 108
         IF (ABS(E2(L)) .LE. ABS(C/H)) GO TO 108
         E2(L) = H*E2(L)
         IF (E2(L) .NE. 0.0) GO TO 105
  108    P = D(L)+F
C
C     ********** ORDER EIGENVALUES **********
C
         IF (L .EQ. 1) GO TO 110
C
C     ********** FOR I=L STEP -1 UNTIL 2 DO -- **********
C
         DO 109 II=2,L
            I = L+2-II
            IF (P .GE. D(I-1)) GO TO 111
            D(I) = D(I-1)
  109    CONTINUE
C
  110    I = 1
  111    D(I) = P
  112 CONTINUE
C
      IF (ABS(D(N)) .GE. ABS(D(1))) GO TO 115
      NHALF = N/2
      DO 113 I=1,NHALF
         NTOP = N-I
         DHOLD = D(I)
         D(I) = D(NTOP+1)
         D(NTOP+1) = DHOLD
  113 CONTINUE
      GO TO 115
C
C     ********** SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30 ITERATIONS **********
C
  114 IERR = L
  115 RETURN
C
C     ********** LAST CARD OF TQLRAT **********
C
      END


SUBROUTINE setaux(mbc,mx,my,xlower,ylower,dx,dy,maux,aux)
    IMPLICIT NONE

    INTEGER mbc, mx,my, meqn, maux
    DOUBLE PRECISION dx,dy, xlower, ylower
    DOUBLE PRECISION aux(maux,1-mbc:mx+mbc,1-mbc:my+mbc)

    INTEGER :: blockno, ghost_only, quadsize
    INTEGER :: i,j, k, m
    DOUBLE PRECISION :: dxdy, xc, yc, nv(3), t, u, v, w
    DOUBLE PRECISION, allocatable, DIMENSION(:) :: quadstore
    DOUBLE PRECISION :: sum, dx0
    INTEGER :: level
    logical :: area_check

    INTEGER maxlevel, rfactor, grid_mx, mi, mj
    COMMON /amr_comm/ maxlevel, rfactor, grid_mx, mi, mj

    INCLUDE "fclaw2d_metric_terms.i"

    area_check = .false.

    !! Figure out level of current grid so we can compute areas
    !! in a conservative manner
    dx0 = 1.d0/(mi*grid_mx)
    level = log((dx0+1d-8)/dx)/log(real(rfactor)) + 1

    !!     # ----------------------------------------------------------------
    !!     # Color equation (edge velocities)
    !!     # 1      capacity
    !!     # 2-3    Edge velocities
    !!     #
    !!     # Conservative form (cell-centered velocities)
    !!     # 2-5    Cell-centered velocities projected onto four edge normals
    !!     # 6-7    Edge lengths (x-face, y-face)
    !!     # ----------------------------------------------------------------

    blockno = 0
    ghost_only = 0

    CALL fclaw2d_fort_compute_mesh(mx,my,mbc,&
                                   xlower,ylower,dx,dy,blockno,xp,yp,zp,xd,yd,zd)

    !! from ForestClaw
    m = rfactor**(maxlevel-level)
    ALLOCATE(quadstore(3*(m+1)*(m+1)))
    quadsize = m
    CALL fclaw2d_fort_compute_area(mx,my,mbc,dx,dy, xlower, ylower, blockno, &
                                   area, quadsize, quadstore, ghost_only)
    DEALLOCATE(quadstore)

    CALL fclaw2d_fort_compute_normals(mx,my,mbc, xp,yp,zp,xd,yd,zd, &
                                      xnormals,ynormals)

    CALL fclaw2d_fort_compute_tangents(mx,my,mbc, xd,yd,zd, xtangents,ytangents, &
                                       edgelengths)

    CALL fclaw2d_fort_compute_surf_normals(mx,my,mbc, xnormals,ynormals, &
                                           edgelengths,curvature, surfnormals,area)

    t = 0
    dxdy = dx*dy

    !!     # Capacity : entry (1)
    DO i = 1-mbc,mx+mbc
        DO j = 1-mbc,my+mbc
            aux(1,i,j) = area(i,j)/dxdy
        END DO
    END DO

    if (area_check) then
        sum = 0
        do i = 1,mx
            do j = 1,my
                sum = sum + area(i,j)
            end do
        end do
        write(6,101) level,sum
        101 format(I5,F24.16)
    endif

    !! # Center velocities : entries (2-5)
    t = 0
    CALL annulus46_set_center_velocities(mx,my,mbc,dx,dy, blockno,xlower,ylower, &
          edgelengths,xnormals,ynormals,surfnormals, t, aux, maux)

    !! # Needed to scale speeds in Riemann solver when using
    !! # cell-centered velocities
    DO i = 1-mbc,mx+mbc
        DO j = 1-mbc,my+mbc
           !! Need to store all four edge lengths in each cell, since they are all
           !! needed in QAD fix.
           aux(12,i,j) = edgelengths(i,j,1)/dy
           aux(13,i,j) = edgelengths(i+1,j,1)/dy
           aux(14,i,j) = edgelengths(i,j,2)/dx
           aux(15,i,j) = edgelengths(i,j+1,2)/dx
        ENDDO
    ENDDO

END SUBROUTINE setaux

SUBROUTINE annulus46_set_center_velocities(mx,my,mbc,dx,dy,blockno, &
     xlower,ylower, edgelengths,xnormals,ynormals,surfnormals, t, aux, maux)
    IMPLICIT NONE

    INTEGER mx,my,mbc,maux,blockno
    DOUBLE PRECISION dx,dy, xlower,ylower
    DOUBLE PRECISION aux(maux,1-mbc:mx+mbc,1-mbc:my+mbc)

    DOUBLE PRECISION xc, yc, x,y, t
    DOUBLE PRECISION vel(3)

    DOUBLE PRECISION nl(3), nb(3), nt(3), nr(3)

    INTEGER i,j, k

    double precision setaux_time
    common /setaux_comm/ setaux_time

    INCLUDE "fclaw2d_metric_terms.i"

!!  This is needed so that aux arrays get set properly.
    t = setaux_time

    !! # Cell-centered velocities : entries (4,5,6)
    DO i = 1-mbc,mx+mbc
        DO j = 1-mbc,my+mbc
            xc = xlower + (i-0.5)*dx
            yc = ylower + (j-0.5)*dy

            CALL annulus_center_velocity(xc,yc,t, vel)

            aux(2,i,j) = vel(1)
            aux(3,i,j) = vel(2)

            DO k = 1,3
                nl(k) = xnormals(i,j,k)
                nr(k) = xnormals(i+1,j,k)
                nb(k) = ynormals(i,j,k)
                nt(k) = ynormals(i,j+1,k)
            ENDDO

            aux(4,i,j) = nl(1)
            aux(5,i,j) = nl(2)
            aux(6,i,j) = nr(1)
            aux(7,i,j) = nr(2)
            aux(8,i,j) = nb(1)
            aux(9,i,j) = nb(2)
            aux(10,i,j) = nt(1)
            aux(11,i,j) = nt(2)
        END DO
    END DO
END SUBROUTINE annulus46_set_center_velocities


c
c This file is used by f2py to generate the Python C wrapper.
c
      subroutine inst_driver(jm, im, calday, dgr_lat, dgr_lon,
     & scon, radius, daysperyear, zen, solin)

c In
      integer jm,im
      real*8 calday
      real*8 dgr_lat(jm)
      real*8 dgr_lon(im)
      real*8 scon
      real*8 radius
      real*8 daysperyear
cf2py intent(in,hide) jm, im
cf2py intent(in) calday, dgr_lat, dgr_lon, scon, radius, daysperyear

c Out
      real*8 zen(jm,im)
      real*8 solin(jm,im)
cf2py intent(out) zen,solin

      do i=1,im
      do j=1,jm
      call insolation(calday, dgr_lat(j), dgr_lon(i), scon,
     & radius, daysperyear, zen(j,i), solin(j,i) )
      enddo
      enddo

      end
c===============================================================================
      subroutine daily_driver(jm, im, calday, dgr_lat, dgr_lon,
     & scon, radius, daysperyear, zen, solin)

c In
      integer jm,im
      real*8 calday
      real*8 dgr_lat(jm)
      real*8 dgr_lon(im)
      real*8 scon
      real*8 radius
      real*8 daysperyear
cf2py intent(in,hide) jm, im
cf2py intent(in) calday, dgr_lat, dgr_lon, scon, radius, daysperyear

c Out
      real*8 zen(jm,im)
      real*8 solin(jm,im)
cf2py intent(out) zen,solin

      do j=1,jm
      call daily_avg_insolation(calday, dgr_lat(j), scon,
     & radius, daysperyear, zen(j,1), solin(j,1) )
      do i=2,im
      zen(j,i) = zen(j,1)
      solin(j,i) = solin(j,1)
      enddo
      enddo

      end
c===============================================================================
      subroutine annual_driver(jm, im, calday, dgr_lat, dgr_lon,
     & scon, radius, daysperyear, zen, solin)

c In
      integer jm,im
      real*8 calday
      real*8 dgr_lat(jm)
      real*8 dgr_lon(im)
      real*8 scon
      real*8 radius
      real*8 daysperyear
cf2py intent(in,hide) jm, im
cf2py intent(in) calday, dgr_lat, dgr_lon, scon, radius, daysperyear

c Out
      real*8 zen(jm,im)
      real*8 solin(jm,im)
cf2py intent(out) zen,solin

      do j=1,jm
      call annual_avg_insolation(dgr_lat(j), scon,
     & radius, daysperyear, zen(j,1), solin(j,1) )
      do i=2,im
      zen(j,i) = zen(j,1)
      solin(j,i) = solin(j,1)
      enddo
      enddo

      end
c===============================================================================
      subroutine berger78_driver(orb_year)

c Input
      integer orb_year
cf2py intent(in) orb_year

c Local
      real*8 eccen, obliq, mvelp
c     Orbital params
      common/orbpar/eccen, obliq, mvelp

      call berger78(orb_year)

      end


      subroutine runF_00iii(i1,i2,i3,f,Gr,Shat5,N0)
C---  Expression for rearrangement of extension of Eq. 5.70
C---  Calculates D00iii
C---  Small terms of order f(i)*Dijkl,Gr(i,j)*Dijklm
      implicit none
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      include 'pvweenumber.f'
      integer ep,N0,k,i1,i2,i3,np
      parameter(np=3)
      double precision f(np),Gr(np,np),den
      double complex Shat5(np,z4max,-2:0)

      do ep=-2,0
      if     ((i1 .eq. i2) .and. (i1 .eq. i3)) then
        den=8d0
        k=i1
      elseif (i1 .eq. i2) then
        den=6d0
        k=i1
      elseif (i1 .eq. i3) then
        den=6d0
        k=i1
      elseif (i2 .eq. i3) then
        den=6d0
        k=i2
      else
        den=4d0
        k=i1
      endif
      Dv(dzziii(z3(i1,i2,i3))+N0,ep)=
     . (Shat5(k,z4(k,i1,i2,i3),ep)
     . -f(k)*Dv(diiii(z4(k,i1,i2,i3))+N0,ep)
     . -Gr(k,1)*Dv(diiiii(z5(1,k,i1,i2,i3))+N0,ep)
     . -Gr(k,2)*Dv(diiiii(z5(2,k,i1,i2,i3))+N0,ep)
     . -Gr(k,3)*Dv(diiiii(z5(3,k,i1,i2,i3))+N0,ep))/den

      enddo

      return
      end


      module MOD_OMEG
      contains
      SUBROUTINE OMEG(N,TL,NCHARG,ELEVEL,EINST, OMEGA, NUP, LOW,
     $                EION,COCO,KEYCOL,WEIGHT,ALTESUM,NATOM,NOM,KODAT)
c*** ,MAXATOM)
      IMPLICIT REAL*8(A-H,O-Z)

      DIMENSION EINST(N,N)
      DIMENSION NCHARG(N),ELEVEL(N),WEIGHT(N)
      DIMENSION EION(N),ALTESUM(4,N)
      DIMENSION COCO(N,N,4)
      DIMENSION NOM(N)
      DIMENSION KODAT(30)
      CHARACTER*4 KEYCOL(N,N)

C***  C1 = H * C / K    ( CM * ANGSTROEM )
      DATA C1 / 1.4388 /

	if (natom.gt.30) stop 'omeg/natom.gt.30'
      TROOT=SQRT(TL)
      T32=TL*TROOT

      WAVENUM=ELEVEL(NUP)-ELEVEL(LOW)
      WN2=WAVENUM*WAVENUM
      WN3=WN2*WAVENUM

C***  ONLY FOR HELIUM ...
      IF (NOM(LOW) .EQ. KODAT(1)) THEN
C***  HE I  *******************************************************************
C***  OMEGA(UP-LOW) IS CALCULATED DEPENDING ON KEYWORD KEYCOL  *********
       IF (NCHARG(LOW).EQ.0) THEN
C***  'JEFF': OPTICALLY PERMITTED  TRANSITIONS. JEFFERIES P. 118 (EQ. 6.24)
C             (VAN REGENMORTER FORMULA) 3.24 = 2.16 / 0.667
         IF (KEYCOL(NUP,LOW) .EQ. 'JEFF') THEN
C                                  ====
              OMEGA=3.24*EINST(NUP,LOW)/WN2/T32/(C1*WAVENUM/TL)**1.68

C***  'BFK ': OPTICALLY FORBIDDEN TRANSITIONS BETWEEN N=2, N=1 OR WITHIN N=2:
C***          BERRINGTON, FON + KINGSTON ('BFK') 1982, MNRAS 200, 347
         ELSE IF (KEYCOL(NUP,LOW) .EQ. 'BFK1') THEN
C                                       ====
              PBFK=COCO(NUP,LOW,1)/TROOT
     +                          +COCO(NUP,LOW,2)+COCO(NUP,LOW,3)*TROOT
     +                          +COCO(NUP,LOW,4)*T32
              OMEGA=PBFK*WEIGHT(LOW)/WEIGHT(NUP)

         ELSE IF (KEYCOL(NUP,LOW) .EQ. 'BFK2') THEN
C                                       ====
              PBFK=COCO(NUP,LOW,1)/TL
     +                          +COCO(NUP,LOW,2)/TROOT+COCO(NUP,LOW,3)
     +                          +COCO(NUP,LOW,4)*TL
              OMEGA=PBFK*WEIGHT(LOW)/WEIGHT(NUP)

C***  'BKMS' OR 'BKGR':
C***  FORBIDDEN TRANSITIONS BETWEEN N.GT.2, N=1 OR N.GT.3, N.NE.1:
C***  BENSON + KULANDER ('BK..') 1972, SOLAR PHYSICS 27, 305 (FORMULA 3)
C***  '..MS': MIHALAS + STONE (REF. 11)
C***  '..GR': GREEN (REF. 7)
C***  ATTENTION: COCO(.,.,3) := 1.-ALPHA !!!!!!!!!!!!!!!!!
          ELSE IF (KEYCOL(NUP,LOW) .EQ. 'BKMS'
C                                        ====
     $        .OR. KEYCOL(NUP,LOW) .EQ. 'BKGR') THEN
C                                        ====
              OMEGA=COCO(NUP,LOW,1)*TL**COCO(NUP,LOW,2)*
     *               EXP(COCO(NUP,LOW,3)*C1*WAVENUM/TL)*WEIGHT(LOW)/
     /               WEIGHT(NUP)

C***  'UPS.': OPTICALLY FORBIDDEN TRANSITIONS BETWEEN N.GT.2, N.NE.1:
C***        EFFECTIVE COLLISIONAL STRENGTH (UPSILON) FROM WERNER SCHMUTZ
          ELSE IF (KEYCOL(NUP,LOW) .EQ. 'UPS0') THEN
C                                        ====
            OMEGA=.0

          ELSE IF (KEYCOL(NUP,LOW) .EQ. 'UPS1') THEN
C                                        ====
              UPSILON=0.05
              OMEGA=8.6287E-6*UPSILON/WEIGHT(NUP)/TROOT

          ELSE IF (KEYCOL(NUP,LOW) .EQ. 'UPS2') THEN
C                                        ====
              UPSILON=1.
              OMEGA=8.6287E-6*UPSILON/WEIGHT(NUP)/TROOT

C***  'NONE': TRANSITIONS (FROM N.GT.4) WITH UNKNOWN COLLISIONAL COEFFICIENTS
C***          (COLLISIONAL CROSS SECTION SIGMA(LOW,UP) IS SET TO  PI*A0**2)
          ELSE IF (KEYCOL(NUP,LOW) .EQ. 'NONE') THEN
C                                        ====
              OMEGA=5.465E-11*TROOT*(1.+C1*WAVENUM/TL)*WEIGHT(LOW)/
     /               WEIGHT(NUP)

C***  'ZERO': NO COLLISIONAL TRANSITION
          ELSE IF (KEYCOL(NUP,LOW) .EQ. 'ZERO') THEN
C                                        ====
              OMEGA=0.

          ELSE
C***  NO/UNKNOWN KEYWORD 'KEYCOL' DECODED
              PRINT *,KEYCOL(NUP,LOW),NUP,LOW
              print *,' OMEG: HE I: WRONG KEYWORD KEYCOL '
              STOP 'ERROR'
          ENDIF

C***  HE II  ******************************************************************
       ELSE IF (NCHARG(LOW).EQ.1) THEN
C***  OMEGA (UP-LOW) ACCORDING TO JEFFERIES P. 119 (EQ. 6.25)
          OMEGA=4.06*EINST(NUP,LOW)/WN3/TROOT
C***  HE III  *****************************************************************
       ELSE
          print *,' OMEG: HE III - LINE TRANSITION  '
          STOP 'ERROR'
       ENDIF
      ELSE IF (NOM(LOW) .EQ. KODAT(2)) THEN
C***  H I  *************************************************************
         IF (NCHARG(LOW) .EQ. 0) THEN
C***  OMEGA (UP-LOW) ACCORDING TO JEFFERIES P. 118 (EQ. 6.24)
            OMEGA=3.24*EINST(NUP,LOW)/WN2/T32/(C1*WAVENUM/TL)**1.68

C***  H II  ************************************************************
         ELSE
            print *,' OMEG: H II - LINE TRANSITION'
            STOP 'ERROR'
         ENDIF
C***  CARBON AND ALL METALS ************************************************************
C***  METALS: INDEX GE 3
      ELSE IF (NOM(LOW) .GE. 3) THEN
C***  ALL IONIZATION STAGES
C***  UPSILON TEMPERATURE INDEPENDENT
C***  OMEGA (UP-LOW) ACCORDING TO JEFFERIES P. 118 (EQ. 6.24)
C
         IF (KEYCOL(NUP,LOW) .EQ. 'CARB') THEN
C                                  ====
            UPSILON=COCO(NUP,LOW,1)
            IF (UPSILON.LE.0.) THEN
               print *,' OMEG: C - UPSILON .LE. 0'
               STOP 'ERROR'
            ENDIF
            OMEGA=8.6287E-6*UPSILON/WEIGHT(NUP)/TROOT
         ELSE
C***  OMEGA (UP-LOW) ACCORDING TO JEFFERIES P. 119 (EQ. 6.25)
            OMEGA=4.06*EINST(NUP,LOW)/WN3/TROOT
c            CALL REMARK ('C - LINE TRANSITION')
c            STOP 'ERROR'
         ENDIF
C***=========================================================
      ELSE
         print *,' OMEG: LINE TRANSITION OF UNKNOWN ELEMENT'
         STOP 'ERROR'
      ENDIF

      RETURN
      END subroutine
      end module


      SUBROUTINE TB01PD( JOB, EQUIL, N, M, P, A, LDA, B, LDB, C, LDC,
     $                   NR, TOL, 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 find a reduced (controllable, observable, or minimal) state-
C     space representation (Ar,Br,Cr) for any original state-space
C     representation (A,B,C). The matrix Ar is in upper block
C     Hessenberg form.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Indicates whether the user wishes to remove the
C             uncontrollable and/or unobservable parts as follows:
C             = 'M':  Remove both the uncontrollable and unobservable
C                     parts to get a minimal state-space representation;
C             = 'C':  Remove the uncontrollable part only to get a
C                     controllable state-space representation;
C             = 'O':  Remove the unobservable part only to get an
C                     observable state-space representation.
C
C     EQUIL   CHARACTER*1
C             Specifies whether the user wishes to preliminarily balance
C             the triplet (A,B,C) as follows:
C             = 'S':  Perform balancing (scaling);
C             = 'N':  Do not perform balancing.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the original state-space representation, i.e.
C             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     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the original state dynamics matrix A.
C             On exit, the leading NR-by-NR part of this array contains
C             the upper block Hessenberg state dynamics matrix Ar of a
C             minimal, controllable, or observable realization for the
C             original system, depending on the value of JOB, JOB = 'M',
C             JOB = 'C', or JOB = 'O', respectively.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M),
C             if JOB = 'C', or (LDB,MAX(M,P)), otherwise.
C             On entry, the leading N-by-M part of this array must
C             contain the original input/state matrix B; if JOB = 'M',
C             or JOB = 'O', the remainder of the leading N-by-MAX(M,P)
C             part is used as internal workspace.
C             On exit, the leading NR-by-M part of this array contains
C             the transformed input/state matrix Br of a minimal,
C             controllable, or observable realization for the original
C             system, depending on the value of JOB, JOB = 'M',
C             JOB = 'C', or JOB = 'O', respectively.
C             If JOB = 'C', only the first IWORK(1) rows of B are
C             nonzero.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the original state/output matrix C; if JOB = 'M',
C             or JOB = 'O', the remainder of the leading MAX(M,P)-by-N
C             part is used as internal workspace.
C             On exit, the leading P-by-NR part of this array contains
C             the transformed state/output matrix Cr of a minimal,
C             controllable, or observable realization for the original
C             system, depending on the value of JOB, JOB = 'M',
C             JOB = 'C', or JOB = 'O', respectively.
C             If JOB = 'M', or JOB = 'O', only the last IWORK(1) columns
C             (in the first NR columns) of C are nonzero.
C
C     LDC     INTEGER
C             The leading dimension of array C.
C             LDC >= MAX(1,M,P) if N > 0.
C             LDC >= 1          if N = 0.
C
C     NR      (output) INTEGER
C             The order of the reduced state-space representation
C             (Ar,Br,Cr) of a minimal, controllable, or observable
C             realization for the original system, depending on
C             JOB = 'M', JOB = 'C', or JOB = 'O'.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance to be used in rank determination when
C             transforming (A, B, C). If the user sets TOL > 0, then
C             the given value of TOL is used as a lower bound for the
C             reciprocal condition number (see the description of the
C             argument RCOND in the SLICOT routine MB03OD);  a
C             (sub)matrix whose estimated condition number is less than
C             1/TOL is considered to be of full rank.  If the user sets
C             TOL <= 0, then an implicitly computed, default tolerance
C             (determined by the SLICOT routine TB01UD) is used instead.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (N+MAX(M,P))
C             On exit, if INFO = 0, the first nonzero elements of
C             IWORK(1:N) return the orders of the diagonal blocks of A.
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, N + MAX(N, 3*M, 3*P)).
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
C     METHOD
C
C     If JOB = 'M', the matrices A and B are operated on by orthogonal
C     similarity transformations (made up of products of Householder
C     transformations) so as to produce an upper block Hessenberg matrix
C     A1 and a matrix B1 with all but its first rank(B) rows zero; this
C     separates out the controllable part of the original system.
C     Applying the same algorithm to the dual of this subsystem,
C     therefore separates out the controllable and observable (i.e.
C     minimal) part of the original system representation, with the
C     final Ar upper block Hessenberg (after using pertransposition).
C     If JOB = 'C', or JOB = 'O', only the corresponding part of the
C     above procedure is applied.
C
C     REFERENCES
C
C     [1] Van Dooren, P.
C         The Generalized Eigenstructure Problem in Linear System
C         Theory. (Algorithm 1)
C         IEEE Trans. Auto. Contr., AC-26, pp. 111-129, 1981.
C
C     NUMERICAL ASPECTS
C                               3
C     The algorithm requires 0(N ) operations and is backward stable.
C
C     CONTRIBUTOR
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998.
C
C     REVISIONS
C
C     A. Varga, DLR Oberpfaffenhofen, July 1998.
C     A. Varga, DLR Oberpfaffenhofen, April 28, 1999.
C     V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004.
C
C     KEYWORDS
C
C     Hessenberg form, minimal realization, multivariable system,
C     orthogonal transformation, state-space model, state-space
C     representation.
C
C     ******************************************************************
C
C     .. Parameters ..
      INTEGER           LDIZ
      PARAMETER         ( LDIZ = 1 )
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         EQUIL, JOB
      INTEGER           INFO, LDA, LDB, LDC, LDWORK, M, N, NR, P
      DOUBLE PRECISION  TOL
C     .. Array Arguments ..
      INTEGER           IWORK(*)
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*)
C     .. Local Scalars ..
      LOGICAL           LEQUIL, LNJOBC, LNJOBO
      INTEGER           I, INDCON, ITAU, IZ, JWORK, KL, MAXMP, NCONT,
     $                  WRKOPT
      DOUBLE PRECISION  MAXRED
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          AB07MD, TB01ID, TB01UD, TB01XD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         INT, MAX, MIN
C     .. Executable Statements ..
C
      INFO = 0
      MAXMP = MAX( M, P )
      LNJOBC = .NOT.LSAME( JOB,   'C' )
      LNJOBO = .NOT.LSAME( JOB,   'O' )
      LEQUIL =      LSAME( EQUIL, 'S' )
C
C     Test the input scalar arguments.
C
      IF( LNJOBC .AND. LNJOBO .AND. .NOT.LSAME( JOB, 'M' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( M.LT.0 ) THEN
         INFO = -4
      ELSE IF( P.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. LDC.LT.MAXMP ) ) THEN
         INFO = -11
      ELSE IF( LDWORK.LT.MAX( 1, N + MAX( N, 3*MAXMP ) ) ) THEN
         INFO = -16
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'TB01PD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 .OR. ( LNJOBC .AND. MIN( N, P ).EQ.0 ) .OR.
     $                 ( LNJOBO .AND. MIN( N, M ).EQ.0 ) ) THEN
         NR = 0
C
         DO 5 I = 1, N
            IWORK(I) = 0
    5    CONTINUE
C
         DWORK(1) = ONE
         RETURN
      END IF
C
C     If required, balance the triplet (A,B,C) (default MAXRED).
C     Workspace: need N.
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of real workspace needed at that point in the code,
C     as well as the preferred amount for good performance.)
C
      IF ( LEQUIL ) THEN
         MAXRED = ZERO
         CALL TB01ID( 'A', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC,
     $                DWORK, INFO )
         WRKOPT = N
      ELSE
         WRKOPT = 1
      END IF
C
      IZ    = 1
      ITAU  = 1
      JWORK = ITAU + N
      IF ( LNJOBO ) THEN
C
C        Separate out controllable subsystem (of order NCONT):
C        A <-- Z'*A*Z,  B <-- Z'*B,  C <-- C*Z.
C
C        Workspace: need   N + MAX(N, 3*M, P).
C                   prefer larger.
C
         CALL TB01UD( 'No Z', N, M, P, A, LDA, B, LDB, C, LDC, NCONT,
     $                INDCON, IWORK, DWORK(IZ), LDIZ, DWORK(ITAU), TOL,
     $                IWORK(N+1), DWORK(JWORK), LDWORK-JWORK+1, INFO )
C
         WRKOPT = INT( DWORK(JWORK) ) + JWORK - 1
      ELSE
         NCONT = N
      END IF
C
      IF ( LNJOBC ) THEN
C
C        Separate out the observable subsystem (of order NR):
C        Form the dual of the subsystem of order NCONT (which is
C        controllable, if JOB = 'M'), leaving rest as it is.
C
         CALL AB07MD( 'Z', NCONT, M, P, A, LDA, B, LDB, C, LDC, DWORK,
     $                1, INFO )
C
C        And separate out the controllable part of this dual subsystem.
C
C        Workspace: need   NCONT + MAX(NCONT, 3*P, M).
C                   prefer larger.
C
         CALL TB01UD( 'No Z', NCONT, P, M, A, LDA, B, LDB, C, LDC, NR,
     $                INDCON, IWORK, DWORK(IZ), LDIZ, DWORK(ITAU), TOL,
     $                IWORK(N+1), DWORK(JWORK), LDWORK-JWORK+1, INFO )
C
         WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
C
C        Transpose and reorder (to get a block upper Hessenberg
C        matrix A), giving, for JOB = 'M', the controllable and
C        observable (i.e., minimal) part of original system.
C
         IF( INDCON.GT.0 ) THEN
            KL = IWORK(1) - 1
            IF ( INDCON.GE.2 )
     $         KL = KL + IWORK(2)
         ELSE
            KL = 0
         END IF
         CALL TB01XD( 'Zero D', NR, P, M, KL, MAX( 0, NR-1 ), A, LDA,
     $                B, LDB, C, LDC, DWORK, 1, INFO )
      ELSE
         NR = NCONT
      END IF
C
C     Annihilate the trailing components of IWORK(1:N).
C
      DO 10 I = INDCON + 1, N
         IWORK(I) = 0
   10 CONTINUE
C
C     Set optimal workspace dimension.
C
      DWORK(1) = WRKOPT
      RETURN
C *** Last line of TB01PD ***
      END