! ##################################################################################################################################

! Begin MIT license text.
! _______________________________________________________________________________________________________

! Copyright 2019 Dr William R Case, Jr (dbcase29@gmail.com)

! Permission is hereby granted, free of charge, to any person obtaining a copy of this software and
! associated documentation files (the "Software"), to deal in the Software without restriction, including
! without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to
! the following conditions:

! The above copyright notice and this permission notice shall be included in all copies or substantial
! portions of the Software and documentation.

! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
! _______________________________________________________________________________________________________

! End MIT license text.

      SUBROUTINE MATL_TRANSFORM_MATRIX ( T21, TS )

! Formulates 6x6 transformation matrix TS which can do a 2D plane coord transformation for stresses, strains and material matrices

! TS is formed from the coefficients in 3x3 coord transformation matrix T21 where T21 is the coord transformation matrix that
! transforms a unit vector in coord sys 1 (U1) to a unit vector in coord sys 2 (U2):

!                                                  U2 = T21*U1                                                         (1)

! For a plane coord transformation (2D, not 3D)

!                                                       |  cos(THETA)  sin(THETA)  0 |
!                                                 T21 = | -sin(THETA)  cos(THETA)  0 |                                 (2)
!                                                       |      0           0       1 |

! The stresses in any coord sys is a tensor (call it S) that is written as:
!                                                    ~
!                                                       | Sxx  Sxy  Sxz |
!                                                   S = | Syx  Syy  Syz |                                              (3)
!                                                   ~   | Szx  Szy  Szz |

! Matrix T21 is used to transform stress tensors from coord sys 1 to coord sys 2 via the equation (NOTE: T21' indicates
! the transpose of matrix T21 which is also T12):

!                                                 S22 = T21'*S11*T21 = T12*S11*T21                                     (4)
!                                                 ~          ~             ~

! The terms in this triple matrix product can be used to rewrite the stress transformation with the 6 independent stresses
! in a vector (instead of as the 3x3 stress tensor). To this end, define the vector:

!                                                       | Sxx |
!                                                       | Syy |
!                                                   S = | Szz |                                                        (5)
!                                                       | Sxy |
!                                                       | Syz |
!                                                       | Szx |

! Then the relationship between S in coord sys 2 and that in coord sys 1 can be written as:

!                                                --------------
!                                               |              |
!                                               |  S2 = TS*S1  |                                                       (6)
!                                               |              |
!                                                --------------

! where TS is a 6x6 matrix of coefficients from T12 (eqn (2)). The 9 terms in T21 are denoted as Aij and the 36 terms in TS,
! developed from the T21 using eqn (4), are developed in the code below. Again, they are developed by expanding the triple
! matrix product (symbolically) in eqn (4) and then rewriting the 6 independent of the resulting 9 equations in the 6x6
! matrix form of (6).

! Matrix TS can also be used to rotate the material matrices from coord sys 1 to coord sys 2 as follows.
! The stress-strain relations in coord sys 1 and 2 are:

!                                                  S1 = E1*e1
!                                                                                (7)
!                                                  S2 = E2*e2

! where ei are strains and Ei is the material matrix in coord sys 1 and 2. Eqn 6 shows how to transform stresses. It is
! the same for strains so that eqns (7) can be written:

!                                                  S2 = TS*S1 = TS*E1*e1                                                       (8)

! but e1 in terms of e2, using the same logic in eqn(6) is

!                                                  e1 = TS'*e2                                                         (9)

! Substituting 9 into 8 yields:

!                                                  S2 = (Ts*E1*TS')*e2 = E2*e2                                         (10)

! so that we conclude:

!                                                ------------------
!                                               |                  |
!                                               |  E2 = TS*E1*TS'  |                                                   (11)
!                                               |                  |
!                                                ------------------

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

      USE PENTIUM_II_KIND, ONLY       :  LONG, DOUBLE
      USE IOUNT1, ONLY                :  F04, F06, WRT_LOG
      USE SCONTR, ONLY                :  BLNK_SUB_NAM
      USE TIMDAT, ONLY                :  TSEC
      USE SUBR_BEGEND_LEVELS, ONLY    :  MATL_TRANSFORM_MATRIX_BEGEND

      IMPLICIT NONE

      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: SUBR_NAME = 'MATL_TRANSFORM_MATRIX'

      INTEGER(LONG), PARAMETER        :: SUBR_BEGEND = MATL_TRANSFORM_MATRIX_BEGEND

      REAL(DOUBLE), INTENT(IN)        :: T21(3,3)          ! 3x3 matrix that transforms a vector in coord sys 1 to coord sys 2
      REAL(DOUBLE), INTENT(OUT)       :: TS(6,6)           ! 6x6 stress transformation matrix
      REAL(DOUBLE)                    :: A11,A12,A13       ! Coefficients from matrix TME
      REAL(DOUBLE)                    :: A21,A22,A23       ! Coefficients from matrix TME
      REAL(DOUBLE)                    :: A31,A32,A33       ! Coefficients from matrix TME

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9001) SUBR_NAME,TSEC
 9001    FORMAT(1X,A,' BEGN ',F10.3)
      ENDIF

! **********************************************************************************************************************************
! Formulate 6x6 matrix TS from terms in 3x3 matrix T12

      A11 = T21(1,1)     ;     A12 = T21(1,2)     ;     A13 = T21(1,3)
      A21 = T21(2,1)     ;     A22 = T21(2,2)     ;     A23 = T21(2,3)
      A31 = T21(3,1)     ;     A32 = T21(3,2)     ;     A33 = T21(3,3)

! Matrix TS is formed from the coefficients in matrix T12 (denoted as Aij coefficients)

! Row 1 of TS:

      TS(1,1)= A11*A11           ;   TS(1,2)= A21*A21           ;   TS(1,3)= A31*A31;
      TS(1,4)= 2*A11*A21         ;   TS(1,5)= 2*A21*A31         ;   TS(1,6)= 2*A11*A31

! Row 2 of TS:

      TS(2,1)= A12*A12           ;   TS(2,2)= A22*A22           ;   TS(2,3)= A32*A32;
      TS(2,4)= 2*A12*A22         ;   TS(2,5)= 2*A22*A32         ;   TS(2,6)= 2*A12*A32

! Row 3 of TS:

      TS(3,1)= A13*A13           ;   TS(3,2)= A23*A23           ;   TS(3,3)= A33*A33;
      TS(3,4)= 2*A13*A23         ;   TS(3,5)= 2*A23*A33         ;   TS(3,6)= 2*A13*A33

! Row 4 of TS:

      TS(4,1)= A11*A12           ;   TS(4,2)= A21*A22           ;   TS(4,3)= A31*A32;
      TS(4,4)= A11*A22+A21*A12   ;   TS(4,5)= A21*A32+A31*A22   ;   TS(4,6)= A11*A32+A31*A12

! Row 5 of TS:

      TS(5,1)= A12*A13           ;   TS(5,2)= A22*A23           ;   TS(5,3)= A32*A33;
      TS(5,4)= A12*A23+A22*A13   ;   TS(5,5)= A22*A33+A32*A23   ;   TS(5,6)= A12*A33+A32*A13

! Row 6 of TS:

      TS(6,1)= A13*A11           ;   TS(6,2)= A23*A21           ;   TS(6,3)= A33*A31;
      TS(6,4)= A13*A21+A23*A11   ;   TS(6,5)= A23*A31+A33*A21   ;   TS(6,6)= A13*A31+A33*A11

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9002) SUBR_NAME,TSEC
 9002    FORMAT(1X,A,' END  ',F10.3)
      ENDIF

      RETURN

! **********************************************************************************************************************************
99664 format('  Transformation matrix TS: transforms 6 stress and 6x6 matl matrices from matl to elem axes')

99667 format(3(1es14.6),4x,3(1es14.6))

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

      END SUBROUTINE MATL_TRANSFORM_MATRIX


!/*--------------------------------------------------------------------*\
! Application
!   random
!
! Purpose
!   Return pseudo-random numbers
!
! This file is provided courtesy of the United States Army Corps of
!   Engineers, Engineer Research and Development Center, Environmental
!   Laboratory. See license file for information on usage.
!
!\*--------------------------------------------------------------------*/

      Subroutine RandomFromSeed(RNDX,SEED)

!Algorithm from:
! "Structured Fortran 77 for Engineers and Scientists, 5th Edition", Author: Delores M. Etter
! Random # is between 0.0 and 1.0

      IMPLICIT NONE

      INTEGER :: SEED

      real*8 :: RNDX

      SEED = 2045*SEED + 1
      SEED = SEED - (SEED/1048576)*1048576
      RNDX = REAL(SEED+1)/1048577.0

!    ! switch between 0 and 1 for tests
!      if (SEED == 1) then
!        SEED = 0
!        RNDX = 0
!      else ! SEED == 0
!        SEED = 1
!        RNDX = 1
!      end if

      RETURN
      END


!< FriVolous, Finite Volume block-structured Fortran abstract class.

module frivolous
!< FriVolous, Finite Volume block-structured Fortran abstract class.

use penf, only : I_P, R_P
use vecfor, only : vector, ex, ey, ez

implicit none
private
public :: block_object

type :: block_object
   !< Finite Volume block-structured Fortran abstract class.
   !<
   !< Object-Oriented designed class for Finite Volume block-structured numerical computations: it allows the easy handling of
   !< metrics data for the robust and efficient computation of numerical spatial operators in the framework of Finite Volume Methods
   !< (FVM). It is based on a simple yet powerful Abstract Data Type (ADT) that is overloaded with useful methods for handling the
   !< back-end operations necessary to compute a numerical spatial operator independently by the actual state variable being
   !< numerically integrated.
   !<
   !< Let us assume that the fluid domain \(D\) is decomposed in \(N_b\) structured blocks \(D^b\), each subdivided in
   !< \(N_i \times N_j \times N_k\) disjoint hexahedrons \(D_{ijk}^b\) such that \(\bigcup D_{ijk}^b = D^b\).
   !< The Finite Volume abstract class is designed to aid the computations of the spatial operators into each block:
   !< $$
   !<\frac{\partial}{{\partial t}}\int\limits_{V_{ijk}} {\overrightarrow U dV}  =
   !<-\sum\limits_{s = 1}^6 {\int\limits_{S_s} {\left(\overline{\overline {F}}\right) \cdot \overrightarrow n dS}} +
   !< \int\limits_{V_{ijk}} {\overrightarrow {{Q}} dV}\label{eq:rans-cons-num}
   !< $$
   !< where \(S_s\) is the \(s^{th}\) face of the finite volume \(D_{ijk}\) whose measure is \(V_{ijk}\).
   !<
   !< A structured block is composed of hexahedron finite volumes with quadrilateral faces using the
   !< following internal numeration for nodes and faces:
   !<```
   !< /|\Z
   !<  |                            F(4)         _ F(6)
   !<  |                            /|\          /!
   !<  |                        7    |          /    8
   !<  |                         *------------------*
   !<  |                        /|   |        /    /|
   !<  |                       / |   |       /    / |
   !<  |                      /  |   |      /    /  |
   !<  |                     /   |   |     /    /   |
   !<  |                    /    |   |    +    /    |
   !<  |                   /     |   |        /     |
   !<  |                  /      |   +       /      |
   !<  |                 /      3|          /       |4
   !<  |                /        * --------/--------*
   !<  |      F(1)<----/----+   /         /        /
   !<  |              *------------------*    +-------->F(2)
   !<  |             5|       /          |6      /
   !<  |              |      /           |      /
   !<  |              |     /        +   |     /
   !<  |              |    /         |   |    /
   !<  |              |   /      +   |   |   /
   !<  |              |  /      /    |   |  /
   !<  |              | /      /     |   | /
   !<  |              |/      /      |   |/
   !<  |              *------------------*
   !<  |             1      /        |    2
   !<  |                   /        \|/
   !<  |   _ Y           |/_       F(3)
   !<  |   /|         F(5)
   !<  |  /
   !<  | /
   !<  |/                                                    X
   !<  O----------------------------------------------------->
   !<```
   !< Each hexadron cells is faces-connected to its neighboring, thus the cells build a structured block with implicit
   !< connectivity, e.g. in 2D space a FriVolous block could be as the following:
   !<```
   !<                 _ J
   !<                 /|                          _____
   !<               5+ ...*----*----*----*----*...     |
   !<               /    /    /    /    /    /         |
   !<              /    /    /    /    /    /          |
   !<            4+ ...*----*----*----*----*...        |
   !<            /    /    /    /    /    /            |
   !<           /    /    /    /    /    /             |
   !<         3+ ...*----*----*----*----*...           |  Structured block of 4x4 Finite Volumes
   !<         /    /    / FV /    /    /               |
   !<        /    /    /    /    /    /                |
   !<      2+ ...*----*----*----*----*...              |
   !<      /    /    /    /    /    /                  |
   !<     /    /    /    /    /    /                   |
   !<   1+ ...*----*----*----*----*...                 |
   !<   /     .    .    .    .    .                    |
   !<  /      .    .    .    .    .               _____
   !< O-------+----+----+----+----+-------------> I
   !<         1    2    3    4    5
   !<```
   !< The nodes of cells are not required to be on the Cartesian coordinates, thus allowing a general
   !< curvilinear mesh: the are 3 implicit coordinate lines, *i*, *j* and *k* that are not required to be orthogonal.
   private
   ! block dimensions
   integer(I_P)              :: Ng(1:6)=[0, 0, 0, 0, 0, 0] !< Number of ghost cells (e.g. used for imposing boundary conditions).
   integer(I_P)              :: Ni=0                       !< Number of cells along the i-th implicit coordinate.
   integer(I_P)              :: Nj=0                       !< Number of cells along the j-th implicit coordinate.
   integer(I_P)              :: Nk=0                       !< Number of cells along the k-th implicit coordinate.
   ! dynamic array members
   type(vector), allocatable :: node(:,:,:)                !< Nodes coordinates.
   type(vector), allocatable :: FNi(:,:,:)                 !< Faces normal along i-th implicit coordinate. NormL2 is the face area.
   type(vector), allocatable :: FNj(:,:,:)                 !< Faces normal along j-th implicit coordinate. NormL2 is the face area.
   type(vector), allocatable :: FNk(:,:,:)                 !< Faces normal along k-th implicit coordinate. NormL2 is the face area.
   real(R_P),    allocatable :: FAi(:,:,:)                 !< Faces area along i-th implicit coordinate. Optionally allocated.
   real(R_P),    allocatable :: FAj(:,:,:)                 !< Faces area along j-th implicit coordinate. Optionally allocated.
   real(R_P),    allocatable :: FAk(:,:,:)                 !< Faces area along k-th implicit coordinate. Optionally allocated.
   real(R_P),    allocatable :: volume(:,:,:)              !< Cells volume.
   ! scalar members
   type(vector)              :: emin                       !< Coordinates of minimum abscissa of the block.
   type(vector)              :: emax                       !< Coordinates of maximum abscissa of the block.
   logical                   :: store_face_area=.false.    !< Activate (separate) faces area storing.
   logical                   :: cartesian=.false.          !< Flag for checking if the block is Cartesian.
   logical                   :: nullify_x=.false.          !< Nullify X direction (2D yz, 1D y or z domain).
   logical                   :: nullify_y=.false.          !< Nullify Y direction (2D xy, 1D x or y domain).
   logical                   :: nullify_z=.false.          !< Nullify Z direction (2D xy, 1D x or y domain).
   contains
      private
      procedure, pass(self), public :: initialize       !< Init block.
      procedure, pass(self), public :: destroy          !< Destroy block.
      procedure, pass(self), public :: linspace         !< Create a Cartesian block with linearly spaced nodes.
      procedure, pass(self), public :: metrics          !< Compute block metrics.
      procedure, pass(self), public :: node2center      !< Compute cell centers coordinates from cell nodes.
      procedure, pass(self), public :: interpolate2node !< Interpolate cell-centered variable to nodes.
      ! procedure, pass(self), public :: residuals        !< Compute finite-volume residuals.
      ! procedure, pass(self), public :: residuals_fast   !< Compute finite-volume residuals. Fast version withoud dot product.
      procedure, pass(self), public :: is_cartesian     !< Return .true. is the block is Cartesian, .false. otherwise.
      final                         :: finalize         !< Finalize block.
      ! operators
      procedure, pass(lhs), public :: assign_block      !< Block = Block.
      ! operators overloading
      generic, public :: assignment(=) => assign_block  !< Overloading = assignament.
endtype block_object

contains
   ! public methods
   subroutine initialize(self, store_face_area, cartesian, nullify_x, nullify_y, nullify_z, emin, emax, Ng, node, Ni, Nj, Nk)
   !< Initialize block.
   class(block_object), intent(inout)        :: self            !< Block.
   logical,             intent(in), optional :: store_face_area !< Activate (separate) faces area storing.
   logical,             intent(in), optional :: cartesian       !< Flag for checking if the block is Cartesian.
   logical,             intent(in), optional :: nullify_x       !< Nullify X direction (2D yz, 1D y or z domain).
   logical,             intent(in), optional :: nullify_y       !< Nullify Y direction (2D xy, 1D x or y domain).
   logical,             intent(in), optional :: nullify_z       !< Nullify Z direction (2D xy, 1D x or y domain).
   type(vector),        intent(in), optional :: emin            !< Coordinates of minimum abscissa of the block.
   type(vector),        intent(in), optional :: emax            !< Coordinates of maximum abscissa of the block.
   integer(I_P),        intent(in), optional :: Ng(1:)          !< Number of ghost cells.
   integer(I_P),        intent(in), optional :: Ni              !< Number of cells along the i-th implicit coordinate.
   integer(I_P),        intent(in), optional :: Nj              !< Number of cells along the j-th implicit coordinate.
   integer(I_P),        intent(in), optional :: Nk              !< Number of cells along the k-th implicit coordinate.
   type(vector),        intent(in), optional :: node(0:,0:,0:)  !< Nodes coordinates.
   integer(I_P)                              :: Ng_(1:6)        !< Number of ghost cells, dummy varibale.

   if (((.not.present(Ni)).and.(.not.present(Nj)).and.(.not.present(Nk))).and.(.not.present(node))) then
      ! raise an error: one between node array or i-j-k dimensions must be provided
      return
   endif

   call self%destroy

   ! set scalar members fisrt
   if (present(emin           )) self%emin            = emin
   if (present(emax           )) self%emax            = emax
   if (present(store_face_area)) self%store_face_area = store_face_area
   if (present(cartesian      )) self%cartesian       = cartesian
   if (present(nullify_x      )) self%nullify_x       = nullify_x
   if (present(nullify_y      )) self%nullify_y       = nullify_y
   if (present(nullify_z      )) self%nullify_z       = nullify_z

   ! set block dimensions
   Ng_ = 0 ; if (present(Ng)) Ng_ = Ng ; self%Ng = Ng_
   if (present(node)) then
      ! infer dimensions from node array
      self%Ni = size(node, dim=1) - self%Ng(1) - self%Ng(2) - 1
      self%Nj = size(node, dim=2) - self%Ng(3) - self%Ng(4) - 1
      self%Nk = size(node, dim=3) - self%Ng(5) - self%Ng(6) - 1
      self%node = node
   else
      ! dimensions are explicitly passed
      self%Ni = Ni
      self%Nj = Nj
      self%Nk = Nk
   endif

   ! allocate dynamic array members
   allocate(self%node  (0 - Ng_(1):Ni + Ng_(2), 0 - Ng_(3):Nj + Ng_(4), 0 - Ng_(5):Nk + Ng_(6)))
   allocate(self%FNi   (0 - Ng_(1):Ni + Ng_(2), 1 - Ng_(3):Nj + Ng_(4), 1 - Ng_(5):Nk + Ng_(6)))
   allocate(self%FNj   (1 - Ng_(1):Ni + Ng_(2), 0 - Ng_(3):Nj + Ng_(4), 1 - Ng_(5):Nk + Ng_(6)))
   allocate(self%FNk   (1 - Ng_(1):Ni + Ng_(2), 1 - Ng_(3):Nj + Ng_(4), 0 - Ng_(5):Nk + Ng_(6)))
   allocate(self%volume(1 - Ng_(1):Ni + Ng_(2), 1 - Ng_(3):Nj + Ng_(4), 1 - Ng_(5):Nk + Ng_(6)))
   if (self%store_face_area) then
      allocate(self%FAi(0 - Ng_(1):Ni + Ng_(2), 1 - Ng_(3):Nj + Ng_(4), 1 - Ng_(5):Nk + Ng_(6)))
      allocate(self%FAj(1 - Ng_(1):Ni + Ng_(2), 0 - Ng_(3):Nj + Ng_(4), 1 - Ng_(5):Nk + Ng_(6)))
      allocate(self%FAk(1 - Ng_(1):Ni + Ng_(2), 1 - Ng_(3):Nj + Ng_(4), 0 - Ng_(5):Nk + Ng_(6)))
   endif
   endsubroutine initialize

   elemental subroutine destroy(self)
   !< Destroy block.
   class(block_object), intent(inout) :: self  !< Block.
   type(block_object)                 :: fresh !< Instance of a new, fresh block used for reset scalars to defaults.

   self = fresh
   endsubroutine destroy

   elemental subroutine linspace(self, emin, emax, error)
   !< Create a Cartesian block with linearly spaced nodes.
   !<
   !< @note If the extents (emin, emax) of the block are not passed, the values eventually passed during block initialization are
   !< used.
   class(block_object), intent(inout)         :: self    !< Block.
   type(vector),        intent(in),  optional :: emin    !< Coordinates of minimum abscissa of the block.
   type(vector),        intent(in),  optional :: emax    !< Coordinates of maximum abscissa of the block.
   integer(I_P),        intent(out), optional :: error   !< Error code.
   integer(I_P)                               :: error_  !< Dummy error code.
   type(vector)                               :: delta   !< Diagonal of block bounding-box.
   real(R_P)                                  :: delta_x !< X component of diagonal of block bounding-box.
   real(R_P)                                  :: delta_y !< Y component of diagonal of block bounding-box.
   real(R_P)                                  :: delta_z !< Z component of diagonal of block bounding-box.
   integer(I_P)                               :: i       !< Counter.
   integer(I_P)                               :: j       !< Counter.
   integer(I_P)                               :: k       !< Counter.

   error_ = 0
   self%cartesian = .true.
   if (present(emin)) self%emin = emin
   if (present(emax)) self%emax = emax
   if (self%emin/=self%emax) then
      delta = (emax - emin)/(self%Ni * ex + self%Nj * ey + self%Nk * ez)
      delta_x = delta.dot.ex
      delta_y = delta.dot.ey
      delta_z = delta.dot.ez
      do k=0 - self%Ng(5), self%Nk + self%Ng(6)
        do j=0 - self%Ng(3), self%Nj + self%Ng(4)
          do i=0 - self%Ng(1), self%Ni + self%Ng(2)
             self%node(i, j, k) = emin + (i * delta_x) * ex + (j * delta_y) * ey + (k * delta_z) * ez
          enddo
        enddo
      enddo
   else
      error_ = 1
   endif
   if (present(error)) error = error_
   endsubroutine linspace

   elemental subroutine metrics(self)
   !< Compute metrics block.
   class(block_object), intent(inout) :: self         !< Block.
   type(vector)                       :: triplet(1:9) !< Dummy vectors.
   real(R_P)                          :: signi        !< Sign of direction of normals along i-th coordinate.
   real(R_P)                          :: signj        !< Sign of direction of normals along i-th coordinate.
   real(R_P)                          :: signk        !< Sign of direction of normals along i-th coordinate.
   integer(I_P)                       :: i            !< Counter.
   integer(I_P)                       :: j            !< Counter.
   integer(I_P)                       :: k            !< Counter.

   ! check direction of normals
   ! set at the middle of the block
   i = max(1, self%Ni)
   j = max(1, self%Nj)
   k = max(1, self%Nk)
   ! i coordinate
   triplet(1) = self%node(i, j,   k) - self%node(i, j-1, k-1)
   triplet(2) = self%node(i, j-1, k) - self%node(i, j,   k-1)
   triplet(3) = triplet(1).cross.triplet(2)
   triplet(4) = (0.25_R_P * (self%node(i,   j, k) + self%node(i,   j-1, k) + self%node(i,   j, k-1) + self%node(i,   j-1, k-1))) - &
                (0.25_R_P * (self%node(i-1, j, k) + self%node(i-1, j-1, k) + self%node(i-1, j, k-1) + self%node(i-1, j-1, k-1)))
   signi = sign(1._R_P, (triplet(3).dot.triplet(4)))
   ! j coordinate
   triplet(1) = self%node(i, j, k  ) - self%node(i-1, j, k-1)
   triplet(2) = self%node(i, j, k-1) - self%node(i-1, j, k  )
   triplet(3) = triplet(1).cross.triplet(2)
   triplet(4) = (0.25_R_P * (self%node(i, j,   k) + self%node(i-1, j,   k) + self%node(i, j,   k-1) + self%node(i-1, j,   k-1))) - &
                (0.25_R_P * (self%node(i, j-1, k) + self%node(i-1, j-1, k) + self%node(i, j-1, k-1) + self%node(i-1, j-1, k-1)))
   signj = sign(1._R_P, (triplet(3).dot.triplet(4)))
   ! k coordinate
   triplet(1) = self%node(i,   j, k) - self%node(i-1, j-1, k)
   triplet(2) = self%node(i-1, j, k) - self%node(i,   j-1, k)
   triplet(3) = triplet(1).cross.triplet(2)
   triplet(4) = (0.25_R_P * (self%node(i, j, k  ) + self%node(i-1, j, k  ) + self%node(i, j-1, k  ) + self%node(i-1, j-1, k  ))) - &
                (0.25_R_P * (self%node(i, j, k-1) + self%node(i-1, j, k-1) + self%node(i, j-1, k-1) + self%node(i-1, j-1, k-1)))
   signk = sign(1._R_P, (triplet(3).dot.triplet(4)))
   ! compute faces normals
   do k=1, self%Nk
      do j=1, self%Nj
         do i=0, self%Ni
            call self%FNi(i, j, k)%face_normal4(pt1 = self%node(i, j-1, k-1), &
                                                pt2 = self%node(i, j  , k-1), &
                                                pt3 = self%node(i, j  , k  ), &
                                                pt4 = self%node(i, j-1, k  ))
            self%FNi(i, j, k) = self%FNi(i, j, k) * signi
         enddo
      enddo
   enddo
   do k=1, self%Nk
      do j=0, self%Nj
         do i=1, self%Ni
            call self%FNj(i, j, k)%face_normal4(pt1 = self%node(i-1, j, k-1), &
                                                pt2 = self%node(i-1, j, k  ), &
                                                pt3 = self%node(i  , j, k  ), &
                                                pt4 = self%node(i  , j, k-1))
            self%FNj(i, j, k) = self%FNj(i, j, k) * signj
         enddo
      enddo
   enddo
   do k=0, self%Nk
      do j=1, self%Nj
         do i=1, self%Ni
            call self%FNk(i, j, k)%face_normal4(pt1 = self%node(i-1, j-1, k), &
                                                pt2 = self%node(i  , j-1, k), &
                                                pt3 = self%node(i  , j  , k), &
                                                pt4 = self%node(i-1, j  , k))
            self%FNk(i, j, k) = self%FNk(i, j, k) * signk
         enddo
      enddo
   enddo
   ! compute finite volumes
   do k=1, self%Nk
      do j=1, self%Nj
         do i=1, self%Ni
            triplet(1) = self%node(i  , j  , k  ) - self%node(i  , j-1, k-1) + self%node(i-1, j  , k  ) - self%node(i-1, j-1, k-1)
            triplet(2) = self%node(i  , j  , k  ) - self%node(i-1, j  , k-1)
            triplet(3) = self%node(i  , j  , k-1) - self%node(i-1, j-1, k-1)
            triplet(4) = self%node(i-1, j  , k  ) - self%node(i-1, j-1, k-1)
            triplet(5) = self%node(i  , j  , k  ) - self%node(i-1, j  , k-1) + self%node(i  , j-1, k  ) - self%node(i-1, j-1, k-1)
            triplet(6) = self%node(i  , j  , k  ) - self%node(i-1, j-1, k  )
            triplet(7) = self%node(i  , j  , k  ) - self%node(i  , j-1, k-1)
            triplet(8) = self%node(i  , j-1, k  ) - self%node(i-1, j-1, k-1)
            triplet(9) = self%node(i  , j  , k  ) - self%node(i-1, j-1, k  ) + self%node(i  , j  , k-1) - self%node(i-1, j-1, k-1)
            self%volume(i, j, k) = (triplet(1).dot.(triplet(2).cross.triplet(3))) + &
                                   (triplet(4).dot.(triplet(5).cross.triplet(6))) + &
                                   (triplet(7).dot.(triplet(8).cross.triplet(9)))
         enddo
      enddo
   enddo
   ! nullify normals for 2D or 1D domains
   if (self%nullify_x) then
      self%FNi = (self%FNi.paral.ex) + (0._R_P * ey      ) + (0._R_P * ez      )
      self%FNj = (0._R_P * ex      ) + (self%FNj.paral.ey) + (self%FNj.paral.ez)
      self%FNk = (0._R_P * ex      ) + (self%FNk.paral.ey) + (self%FNk.paral.ez)
   endif
   if (self%nullify_y) then
      self%FNi = (self%FNi.paral.ex) + (0._R_P * ey      ) + (self%FNi.paral.ez)
      self%FNj = (0._R_P * ex      ) + (self%FNj.paral.ey) + (0._R_P * ez      )
      self%FNk = (self%FNk.paral.ex) + (0._R_P * ey      ) + (self%FNk.paral.ez)
   endif
   if (self%nullify_z) then
      self%FNi = (self%FNi.paral.ex) + (self%FNi.paral.ey) + (0._R_P * ez      )
      self%FNj = (self%FNj.paral.ex) + (self%FNj.paral.ey) + (0._R_P * ez      )
      self%FNk = (0._R_P * ex      ) + (0._R_P * ey      ) + (self%FNk.paral.ez)
   endif
   endsubroutine metrics

   pure function node2center(self) result(center)
   !< Compute cell centers coordinates from cell nodes.
   class(block_object), intent(in) :: self          !< Block.
   type(vector), allocatable       :: center(:,:,:) !< Cell centers coordinates.
   integer(I_P)                    :: i             !< Counter.
   integer(I_P)                    :: j             !< Counter.
   integer(I_P)                    :: k             !< Counter.

   allocate(center(1 - self%Ng(1):self%Ni + self%Ng(2), 1 - self%Ng(3):self%Nj + self%Ng(4), 1 - self%Ng(5):self%Nk + self%Ng(6)))
   do k=1 - self%Ng(5), self%Nk + self%Ng(6)
      do j=1 - self%Ng(3), self%Nj + self%Ng(4)
         do i=1 - self%Ng(1), self%Ni + self%Ng(2)
            center(i, j, k) = (self%node(i,   j,   k  ) + &
                               self%node(i-1, j,   k  ) + &
                               self%node(i  , j-1, k  ) + &
                               self%node(i  , j  , k-1) + &
                               self%node(i-1, j-1, k-1) + &
                               self%node(i  , j-1, k-1) + &
                               self%node(i-1, j  , k-1) + &
                               self%node(i-1, j-1, k  )) * 0.125_R_P
         enddo
      enddo
   enddo
   endfunction node2center

   pure subroutine interpolate2node(self, var_cell, var_node)
   !< Interpolate cell-centered variable to nodes.
   !<
   !< @note The interpolation is linear and based on the volume-weights.
   !<
   !< @note Only internal cells are considered, ghost ones are trimmed.
   class(block_object), intent(in)  :: self                                                  !< Block.
   real(R_P),           intent(in)  :: var_cell(1-self%Ng(1):, 1-self%Ng(3):, 1-self%Ng(5):) !< Cell-centered variable.
   real(R_P),           intent(out) :: var_node(0-self%Ng(1):, 0-self%Ng(3):, 0-self%Ng(5):) !< Node-centered variable.
   real(R_P), allocatable           :: var_cell_framed(:,:,:)                                !< Cell-centered var framed.
   real(R_P), allocatable           :: volume_framed(:,:,:)                                  !< Volume framed.
   integer(I_P)                     :: i                                                     !< Counter.
   integer(I_P)                     :: j                                                     !< Counter.
   integer(I_P)                     :: k                                                     !< Counter.

   ! building framed variable and volume
   allocate(var_cell_framed(0:self%Ni+1, 0:self%Nj+1, 0:self%Nk+1)) ; var_cell_framed = 0._R_P
   var_cell_framed(1:self%Ni, 1:self%Nj, 1:self%Nk) = var_cell(1:self%Ni, 1:self%Nj, 1:self%Nk)
   allocate(volume_framed(0:self%Ni+1, 0:self%Nj+1, 0:self%Nk+1)) ; volume_framed = 0._R_P
   volume_framed(1:self%Ni, 1:self%Nj, 1:self%Nk) = self%volume(1:self%Ni, 1:self%Nj, 1:self%Nk)
   ! check frames
   if (self%Ng(1)>0) then
      var_cell_framed(0, 1:self%Nj, 1:self%Nk) = var_cell(   0, 1:self%Nj, 1:self%Nk)
      volume_framed(  0, 1:self%Nj, 1:self%Nk) = self%volume(0, 1:self%Nj, 1:self%Nk)
   endif
   if (self%Ng(2)>0) then
      var_cell_framed(self%Ni+1, 1:self%Nj, 1:self%Nk) = var_cell(   self%Ni+1, 1:self%Nj, 1:self%Nk)
      volume_framed(  self%Ni+1, 1:self%Nj, 1:self%Nk) = self%volume(self%Ni+1, 1:self%Nj, 1:self%Nk)
   endif
   if (self%Ng(3)>0) then
      var_cell_framed(1:self%Ni, 0, 1:self%Nk) = var_cell(   1:self%Ni, 0, 1:self%Nk)
      volume_framed(  1:self%Ni, 0, 1:self%Nk) = self%volume(1:self%Ni, 0, 1:self%Nk)
   endif
   if (self%Ng(4)>0) then
      var_cell_framed(self%Ni, 1:self%Nj+1, 1:self%Nk) = var_cell(   self%Ni, 1:self%Nj+1, 1:self%Nk)
      volume_framed(  self%Ni, 1:self%Nj+1, 1:self%Nk) = self%volume(self%Ni, 1:self%Nj+1, 1:self%Nk)
   endif
   if (self%Ng(5)>0) then
      var_cell_framed(1:self%Ni, 1:self%Nj, 0) = var_cell(   1:self%Ni, 1:self%Nj, 0)
      volume_framed(  1:self%Ni, 1:self%Nj, 0) = self%volume(1:self%Ni, 1:self%Nj, 0)
   endif
   if (self%Ng(6)>0) then
      var_cell_framed(self%Ni, 1:self%Nj, 1:self%Nk+1) = var_cell(   self%Ni, 1:self%Nj, 1:self%Nk+1)
      volume_framed(  self%Ni, 1:self%Nj, 1:self%Nk+1) = self%volume(self%Ni, 1:self%Nj, 1:self%Nk+1)
   endif
   ! interpolate on nodes
   do k=0, self%Nk
      do j=0, self%Nj
         do i=0, self%Ni
            var_node(i, j, k) = (var_cell_framed(i+1, j+1, k+1) * volume_framed(i+1, j+1, k+1) &
                              +  var_cell_framed(i  , j+1, k+1) * volume_framed(i  , j+1, k+1) &
                              +  var_cell_framed(i+1, j  , k+1) * volume_framed(i+1, j  , k+1) &
                              +  var_cell_framed(i  , j  , k+1) * volume_framed(i  , j  , k+1) &
                              +  var_cell_framed(i+1, j+1, k  ) * volume_framed(i+1, j+1, k  ) &
                              +  var_cell_framed(i  , j+1, k  ) * volume_framed(i  , j+1, k  ) &
                              +  var_cell_framed(i+1, j  , k  ) * volume_framed(i+1, j  , k  ) &
                              +  var_cell_framed(i  , j  , k  ) * volume_framed(i  , j  , k  ))&
                              / sum(volume_framed(i:i+1, j:j+1, k:k+1))
         enddo
      enddo
   enddo
   endsubroutine interpolate2node

   ! subroutine residuals(self, Fi, Fj, Fk, res)
   ! !< Compute finite-volume residuals.
   ! class(block_object), intent(in)    :: self                                             !< Block.
   ! class(conservative), intent(in)    :: Fi(0-self%Ng(1):, 1-self%Ng(3):, 1-self%Ng(5):)  !< Fluxes on *i* interfaces.
   ! class(conservative), intent(in)    :: Fj(1-self%Ng(1):, 0-self%Ng(3):, 1-self%Ng(5):)  !< Fluxes on *j* interfaces.
   ! class(conservative), intent(in)    :: Fk(1-self%Ng(1):, 1-self%Ng(3):, 0-self%Ng(5):)  !< Fluxes on *k* interfaces.
   ! class(conservative), intent(inout) :: res(1:, 1:, 1:)                                  !< Residuals.
   ! integer(I_P)                       :: i                                                !< Counter.
   ! integer(I_P)                       :: j                                                !< Counter.
   ! integer(I_P)                       :: k                                                !< Counter.

   ! ! select type(Fi)
   ! ! class is (conservative)
   !   do k=1, self%Nk
   !     do j=1, self%Nj
   !       do i=1, self%Ni
   !         res(i, j, k) = ((Fi(i-1, j  ,  k  ).dot.self%FNi(i-1, j  , k  )) - (Fi(i, j, k).dot.self%FNi(i, j, k))  &
   !                      +  (Fj(i  , j-1,  k  ).dot.self%FNj(i  , j-1, k  )) - (Fj(i, j, k).dot.self%FNj(i, j, k))  &
   !                      +  (Fk(i  , j  ,  k-1).dot.self%FNk(i  , j  , k-1)) - (Fk(i, j, k).dot.self%FNk(i, j, k))) &
   !                      / self%volume(i, j, k)
   !       enddo
   !     enddo
   !   enddo
   ! ! endselect
   ! endsubroutine residuals

   ! subroutine residuals_fast(self, Fi, Fj, Fk, res)
   ! !< Compute finite-volume residuals.
   ! !<
   ! !< @note this version of *residuals* compuation is based on the assumption that fluxes *Fi, Fj, Fk* are already provided as the
   ! !< *normal (to the interface) component*, thus the dot product can be omitted. As a matter of facts, during the computation of
   ! !< fluxes the normal and tangential components are generally computed separately: there is no need to perform the dot product
   ! !< twice, thus, in those cases, this residual procedure should be faster than the more general above one.
   ! !<
   ! !< @note this version of *residuals* assumes that *faces area* are stored *separately* into `self%FA(i,j,k)`, however no check
   ! !< is done (for not hurting performances).
   ! class(block_object), intent(in)    :: self                                             !< Block.
   ! class(conservative), intent(in)    :: Fi(0-self%Ng(1):, 1-self%Ng(3):, 1-self%Ng(5):)  !< Fluxes on *i* interfaces.
   ! class(conservative), intent(in)    :: Fj(1-self%Ng(1):, 0-self%Ng(3):, 1-self%Ng(5):)  !< Fluxes on *j* interfaces.
   ! class(conservative), intent(in)    :: Fk(1-self%Ng(1):, 1-self%Ng(3):, 0-self%Ng(5):)  !< Fluxes on *k* interfaces.
   ! class(conservative), intent(inout) :: res(1:, 1:, 1:)                                  !< Residuals.
   ! integer(I_P)                       :: i                                                !< Counter.
   ! integer(I_P)                       :: j                                                !< Counter.
   ! integer(I_P)                       :: k                                                !< Counter.

   ! ! select type(Fi)
   ! ! class is (conservative)
   !   do k=1, self%Nk
   !     do j=1, self%Nj
   !       do i=1, self%Ni
   !         res(i, j, k) = ((Fi(i-1, j  ,  k  ) * self%FAi(i-1, j  , k  )) - (Fi(i, j, k) * self%FAi(i, j, k))  &
   !                      +  (Fj(i  , j-1,  k  ) * self%FAj(i  , j-1, k  )) - (Fj(i, j, k) * self%FAj(i, j, k))  &
   !                      +  (Fk(i  , j  ,  k-1) * self%FAk(i  , j  , k-1)) - (Fk(i, j, k) * self%FAk(i, j, k))) &
   !                      / self%volume(i, j, k)
   !       enddo
   !     enddo
   !   enddo
   ! ! endselect
   ! endsubroutine residuals_fast

   elemental function is_cartesian(self) result(is_it)
   !< Return .true. is the block is Cartesian, .false. otherwise.
   class(block_object), intent(in) :: self  !< Block.
   logical                         :: is_it !< Is it Cartesian or not?

   is_it = self%cartesian
   endfunction is_cartesian

   ! private methods
   subroutine finalize(self)
   !< Destroy block.
   type(block_object), intent(inout) :: self !< Block.

   call self%destroy
   endsubroutine finalize

   pure subroutine assign_block(lhs, rhs)
   !< Symmetric assignment block = block.
   class(block_object), intent(inout) :: lhs !< Left hand side.
   type(block_object),  intent(in)    :: rhs !< Right hand side.

   lhs%Ng = rhs%Ng
   lhs%Ni = rhs%Ni
   lhs%Nj = rhs%Nj
   lhs%Nk = rhs%Nk
   if (allocated(rhs%node)) then
      lhs%node = rhs%node
   else
      if (allocated(lhs%node)) deallocate(lhs%node)
   endif
   if (allocated(rhs%FNi)) then
      lhs%FNi = rhs%FNi
   else
      if (allocated(lhs%FNi)) deallocate(lhs%FNi)
   endif
   if (allocated(rhs%FNj)) then
      lhs%FNj = rhs%FNj
   else
      if (allocated(lhs%FNj)) deallocate(lhs%FNj)
   endif
   if (allocated(rhs%FNk)) then
      lhs%FNk = rhs%FNk
   else
      if (allocated(lhs%FNk)) deallocate(lhs%FNk)
   endif
   if (allocated(rhs%FAi)) then
      lhs%FAi = rhs%FAi
   else
      if (allocated(lhs%FAi)) deallocate(lhs%FAi)
   endif
   if (allocated(rhs%FAj)) then
      lhs%FAj = rhs%FAj
   else
      if (allocated(lhs%FAj)) deallocate(lhs%FAj)
   endif
   if (allocated(rhs%FAk)) then
      lhs%FAk = rhs%FAk
   else
      if (allocated(lhs%FAk)) deallocate(lhs%FAk)
   endif
   if (allocated(rhs%volume)) then
      lhs%volume = rhs%volume
   else
      if (allocated(lhs%volume)) deallocate(lhs%volume)
   endif
   lhs%emin            = rhs%emin
   lhs%emax            = rhs%emax
   lhs%store_face_area = rhs%store_face_area
   lhs%cartesian       = rhs%cartesian
   lhs%nullify_x       = rhs%nullify_x
   lhs%nullify_y       = rhs%nullify_y
   lhs%nullify_z       = rhs%nullify_z
   endsubroutine assign_block
endmodule frivolous


      SUBROUTINE SSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
*
*  -- LAPACK routine (version 1.0b) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     October 31, 1992
*
*     .. Scalar Arguments ..
      CHARACTER          COMPZ
      INTEGER            INFO, LDZ, N
*     ..
*     .. Array Arguments ..
      REAL               D( * ), E( * ), WORK( * ), Z( LDZ, * )
*     ..
*
*  Purpose
*  =======
*
*  SSTEQR computes all eigenvalues and, optionally, eigenvectors of a
*  symmetric tridiagonal matrix using the implicit QL or QR method.
*  The eigenvectors of a full or band symmetric matrix can also be found
*  if SSYTRD or SSPTRD or SSBTRD has been used to reduce this matrix to
*  tridiagonal form.
*
*  Arguments
*  =========
*
*  COMPZ   (input) CHARACTER*1
*          Specifies whether eigenvectors are to be computed
*          as follows
*
*             COMPZ = 'N' or 'n'     Compute eigenvalues only.
*
*             COMPZ = 'V' or 'v'     Compute eigenvectors of original
*                                    symmetric matrix also.
*                                    Array Z contains the orthogonal
*                                    matrix used to reduce the original
*                                    matrix to tridiagonal form.
*
*             COMPZ = 'I' or 'i'     Compute eigenvectors of
*                                    tridiagonal matrix also.
*
*  N       (input) INTEGER
*          The number of rows and columns in the matrix.  N >= 0.
*
*  D       (input/output) REAL array, dimension (N)
*          On entry, the diagonal elements of the tridiagonal matrix.
*          On exit, if INFO = 0, the eigenvalues in ascending order.
*
*  E       (input/output) REAL array, dimension (N-1)
*          On entry, the subdiagonal elements of the tridiagonal matrix.
*          On exit, E has been destroyed.
*
*  Z       (input/output) REAL array, dimension (LDZ, N)
*          If  COMPZ = 'V' or 'v', then:
*          On entry, Z contains the orthogonal matrix used in the
*          reduction to tridiagonal form.
*          If  COMPZ = 'V' or 'v' or 'I' or 'i', then:
*          On exit, if INFO = 0, Z contains the orthonormal eigenvectors
*          of the symmetric tridiagonal (or full) matrix.
*
*          If  COMPZ = 'N' or 'n', then Z is not referenced.
*
*  LDZ     (input) INTEGER
*          The leading dimension of the array Z.  If eigenvectors are
*          desired, then  LDZ >= max( 1, N ).  In any case,  LDZ >= 1.
*
*  WORK    (workspace) REAL array, dimension (max(1,2*N-2))
*          Workspace used in computing eigenvectors.
*          If  COMPZ = 'N' or 'n', then WORK is not referenced.
*
*  INFO    (output) INTEGER
*          = 0:  successful exit.
*          < 0:  if INFO = -i, the i-th argument had an illegal value.
*          > 0:  the algorithm has failed to find all the eigenvalues in
*                a total of 30*N iterations; if INFO = i, then i
*                elements of E have not converged to zero; on exit, D
*                and E contain the elements of a symmetric tridiagonal
*                matrix which is orthogonally similar to the original
*                matrix.
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE, TWO
      PARAMETER          ( ZERO = 0.0, ONE = 1.0, TWO = 2.0 )
      INTEGER            MAXIT
      PARAMETER          ( MAXIT = 30 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, ICOMPZ, II, J, JTOT, K, L, L1, LEND, LENDM1,
     $                   LENDP1, LM1, M, MM, MM1, NM1, NMAXIT
      REAL               B, C, EPS, F, G, P, R, RT1, RT2, S, TST
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      REAL               SLAMCH, SLAPY2
      EXTERNAL           LSAME, SLAMCH, SLAPY2
*     ..
*     .. External Subroutines ..
      EXTERNAL           SLAE2, SLAEV2, SLARTG, SLASR, SLAZRO, SSWAP,
     $                   XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SIGN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
*
      IF( LSAME( COMPZ, 'N' ) ) THEN
         ICOMPZ = 0
      ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
         ICOMPZ = 1
      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
         ICOMPZ = 2
      ELSE
         ICOMPZ = -1
      END IF
      IF( ICOMPZ.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1,
     $         N ) ) ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SSTEQR', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
      IF( N.EQ.1 ) THEN
         IF( ICOMPZ.GT.0 )
     $      Z( 1, 1 ) = ONE
         RETURN
      END IF
*
*     Determine the unit roundoff for this environment.
*
      EPS = SLAMCH( 'E' )
*
*     Compute the eigenvalues and eigenvectors of the tridiagonal
*     matrix.
*
      IF( ICOMPZ.EQ.2 )
     $   CALL SLAZRO( N, N, ZERO, ONE, Z, LDZ )
*
      NMAXIT = N*MAXIT
      JTOT = 0
*
*     Determine where the matrix splits and choose QL or QR iteration
*     for each block, according to whether top or bottom diagonal
*     element is smaller.
*
      L1 = 1
      NM1 = N - 1
*
   10 CONTINUE
      IF( L1.GT.N )
     $   GO TO 160
      IF( L1.GT.1 )
     $   E( L1-1 ) = ZERO
      IF( L1.LE.NM1 ) THEN
         DO 20 M = L1, NM1
            TST = ABS( E( M ) )
            IF( TST.LE.EPS*( ABS( D( M ) )+ABS( D( M+1 ) ) ) )
     $         GO TO 30
   20    CONTINUE
      END IF
      M = N
*
   30 CONTINUE
      L = L1
      LEND = M
      IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN
         L = LEND
         LEND = L1
      END IF
      L1 = M + 1
*
      IF( LEND.GE.L ) THEN
*
*        QL Iteration
*
*        Look for small subdiagonal element.
*
   40    CONTINUE
         IF( L.NE.LEND ) THEN
            LENDM1 = LEND - 1
            DO 50 M = L, LENDM1
               TST = ABS( E( M ) )
               IF( TST.LE.EPS*( ABS( D( M ) )+ABS( D( M+1 ) ) ) )
     $            GO TO 60
   50       CONTINUE
         END IF
*
         M = LEND
*
   60    CONTINUE
         IF( M.LT.LEND )
     $      E( M ) = ZERO
         P = D( L )
         IF( M.EQ.L )
     $      GO TO 80
*
*        If remaining matrix is 2-by-2, use SLAE2 or SLAEV2
*        to compute its eigensystem.
*
         IF( M.EQ.L+1 ) THEN
            IF( ICOMPZ.GT.0 ) THEN
               CALL SLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S )
               WORK( L ) = C
               WORK( N-1+L ) = S
               CALL SLASR( 'R', 'V', 'B', N, 2, WORK( L ),
     $                     WORK( N-1+L ), Z( 1, L ), LDZ )
            ELSE
               CALL SLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 )
            END IF
            D( L ) = RT1
            D( L+1 ) = RT2
            E( L ) = ZERO
            L = L + 2
            IF( L.LE.LEND )
     $         GO TO 40
            GO TO 10
         END IF
*
         IF( JTOT.EQ.NMAXIT )
     $      GO TO 140
         JTOT = JTOT + 1
*
*        Form shift.
*
         G = ( D( L+1 )-P ) / ( TWO*E( L ) )
         R = SLAPY2( G, ONE )
         G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) )
*
         S = ONE
         C = ONE
         P = ZERO
*
*        Inner loop
*
         MM1 = M - 1
         DO 70 I = MM1, L, -1
            F = S*E( I )
            B = C*E( I )
            CALL SLARTG( G, F, C, S, R )
            IF( I.NE.M-1 )
     $         E( I+1 ) = R
            G = D( I+1 ) - P
            R = ( D( I )-G )*S + TWO*C*B
            P = S*R
            D( I+1 ) = G + P
            G = C*R - B
*
*           If eigenvectors are desired, then save rotations.
*
            IF( ICOMPZ.GT.0 ) THEN
               WORK( I ) = C
               WORK( N-1+I ) = -S
            END IF
*
   70    CONTINUE
*
*        If eigenvectors are desired, then apply saved rotations.
*
         IF( ICOMPZ.GT.0 ) THEN
            MM = M - L + 1
            CALL SLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ),
     $                  Z( 1, L ), LDZ )
         END IF
*
         D( L ) = D( L ) - P
         E( L ) = G
         GO TO 40
*
*        Eigenvalue found.
*
   80    CONTINUE
         D( L ) = P
*
         L = L + 1
         IF( L.LE.LEND )
     $      GO TO 40
         GO TO 10
*
      ELSE
*
*        QR Iteration
*
*        Look for small superdiagonal element.
*
   90    CONTINUE
         IF( L.NE.LEND ) THEN
            LENDP1 = LEND + 1
            DO 100 M = L, LENDP1, -1
               TST = ABS( E( M-1 ) )
               IF( TST.LE.EPS*( ABS( D( M ) )+ABS( D( M-1 ) ) ) )
     $            GO TO 110
  100       CONTINUE
         END IF
*
         M = LEND
*
  110    CONTINUE
         IF( M.GT.LEND )
     $      E( M-1 ) = ZERO
         P = D( L )
         IF( M.EQ.L )
     $      GO TO 130
*
*        If remaining matrix is 2-by-2, use SLAE2 or SLAEV2
*        to compute its eigensystem.
*
         IF( M.EQ.L-1 ) THEN
            IF( ICOMPZ.GT.0 ) THEN
               CALL SLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S )
               WORK( M ) = C
               WORK( N-1+M ) = S
               CALL SLASR( 'R', 'V', 'F', N, 2, WORK( M ),
     $                     WORK( N-1+M ), Z( 1, L-1 ), LDZ )
            ELSE
               CALL SLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 )
            END IF
            D( L-1 ) = RT1
            D( L ) = RT2
            E( L-1 ) = ZERO
            L = L - 2
            IF( L.GE.LEND )
     $         GO TO 90
            GO TO 10
         END IF
*
         IF( JTOT.EQ.NMAXIT )
     $      GO TO 140
         JTOT = JTOT + 1
*
*        Form shift.
*
         G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) )
         R = SLAPY2( G, ONE )
         G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) )
*
         S = ONE
         C = ONE
         P = ZERO
*
*        Inner loop
*
         LM1 = L - 1
         DO 120 I = M, LM1
            F = S*E( I )
            B = C*E( I )
            CALL SLARTG( G, F, C, S, R )
            IF( I.NE.M )
     $         E( I-1 ) = R
            G = D( I ) - P
            R = ( D( I+1 )-G )*S + TWO*C*B
            P = S*R
            D( I ) = G + P
            G = C*R - B
*
*           If eigenvectors are desired, then save rotations.
*
            IF( ICOMPZ.GT.0 ) THEN
               WORK( I ) = C
               WORK( N-1+I ) = S
            END IF
*
  120    CONTINUE
*
*        If eigenvectors are desired, then apply saved rotations.
*
         IF( ICOMPZ.GT.0 ) THEN
            MM = L - M + 1
            CALL SLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ),
     $                  Z( 1, M ), LDZ )
         END IF
*
         D( L ) = D( L ) - P
         E( LM1 ) = G
         GO TO 90
*
*        Eigenvalue found.
*
  130    CONTINUE
         D( L ) = P
*
         L = L - 1
         IF( L.GE.LEND )
     $      GO TO 90
         GO TO 10
*
      END IF
*
*     Set error -- no convergence to an eigenvalue after a total
*     of N*MAXIT iterations.
*
  140 CONTINUE
      DO 150 I = 1, N - 1
         IF( E( I ).NE.ZERO )
     $      INFO = INFO + 1
  150 CONTINUE
      RETURN
*
*     Order eigenvalues and eigenvectors.
*
  160 CONTINUE
      DO 180 II = 2, N
         I = II - 1
         K = I
         P = D( I )
         DO 170 J = II, N
            IF( D( J ).LT.P ) THEN
               K = J
               P = D( J )
            END IF
  170    CONTINUE
         IF( K.NE.I ) THEN
            D( K ) = D( I )
            D( I ) = P
            IF( ICOMPZ.GT.0 )
     $         CALL SSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
         END IF
  180 CONTINUE
*
      RETURN
*
*     End of SSTEQR
*
      END


      SUBROUTINE DEMVV(N,X,Y)
*     .. Scalar Arguments ..
      INTEGER N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION X(*),Y(*)
*     ..
*
*  Purpose
*  =======
**
*     inplace elementwise vector-vector multiply.
*
*     Y <- X .* Y
*
*     BLAS seems to have no subroutine for this
*     so this is a trivial implementation
*     (not using BLAS style loop unrolling etc.,
*     no increment, etc.)
*     just to keep things simple.
*     An alternative implementation would be to
*     put one vector on main diagonal of a matrix
*     and use Level 2 BLAS subroutine DGBMV
*     Alex Stivala 04July2008.
*     $Id: demvv.F 2969 2009-11-22 01:29:39Z astivala $
*
* Arguments
* =========
*
*  X      - DOUBLE PRECISION vector of dimension N
*           input vector X
*
*  Y      - DOUBLE PRECISION vector of dimension N
*           on input, values of vector Y
*           on exit each element Y(i)
*           is set to X(i)*y(i)
*           where y(i) is input Y value.
*
*
*     .. Local Scalars ..
      INTEGER I
*     ..
*
      DO 10 I = 1,N
          Y(I) = X(I) * Y(I)
   10 CONTINUE
      RETURN
      END


PROGRAM demo_graph
use m_graph, only : graph, graph_init
use M_draw
use M_msg,   only : str
implicit none

integer,PARAMETER            :: NUMLINES=3
integer,PARAMETER            :: NUMPTS=25
integer,PARAMETER            :: NF=255
REAL                         :: X(NUMPTS),Y(NUMPTS,NUMLINES)
CHARACTER(len=80)            :: C(NUMLINES+3)
INTEGER                      :: NC(NUMLINES+3)
REAL                         :: F(NF)
character(len=20)            :: device
integer                      :: ixsize
integer                      :: iysize
integer                      :: i20, i60, i70
integer                      :: ndp
integer                      :: ndl
!!character(len=:),allocatable :: filename
integer                      :: w
! create a NAMELIST group with lots of options
real :: view(3)=[0.0,0.0,0.0]
character(len=80) :: t='title'
character(len=80) :: fontname='roman'
logical :: h=.false.
real  ::  grid                       ;  equivalence(f(42),grid)                       ;  namelist  /args/grid
real  ::  symbol_connect             ;  equivalence(f(10),symbol_connect)             ;  namelist  /args/symbol_connect
real  ::  symbol_nth                 ;  equivalence(f(11),symbol_nth)                 ;  namelist  /args/symbol_nth
real  ::  symbol_size                ;  equivalence(f(12),symbol_size)                ;  namelist  /args/symbol_size
real  ::  symbol_start               ;  equivalence(f(13),symbol_start)               ;  namelist  /args/symbol_start
real  ::  error_bar_option           ;  equivalence(f(14),error_bar_option)           ;  namelist  /args/error_bar_option
real  ::  error_bar_size             ;  equivalence(f(16),error_bar_size)             ;  namelist  /args/error_bar_size
real  ::  x_axis_number_orientation  ;  equivalence(f(31),x_axis_number_orientation)  ;  namelist  /args/x_axis_number_orientation
real  ::  y_axis_number_orientation  ;  equivalence(f(32),y_axis_number_orientation)  ;  namelist  /args/y_axis_number_orientation
real  ::  x_axis_length              ;  equivalence(f(21),x_axis_length)              ;  namelist  /args/x_axis_length
real  ::  y_axis_length              ;  equivalence(f(22),y_axis_length)              ;  namelist  /args/y_axis_length
real  ::  x_axis_label_size          ;  equivalence(f(39),x_axis_label_size)          ;  namelist  /args/x_axis_label_size
real  ::  y_axis_label_size          ;  equivalence(f(40),y_axis_label_size)          ;  namelist  /args/y_axis_label_size
real  ::  top_title_size             ;  equivalence(f(41),top_title_size)             ;  namelist  /args/top_title_size
namelist /args/ view,t,h,fontname,f
character(len=:),allocatable :: status
!-----------------------------------------------------------------------------------------------------------------------------------
   device='x11'
   ixsize=1200*.75*0.5
   iysize=900*.75*0.5
   w=40
   if(device.eq.'x11')then
      call prefposition(0,0)
      call prefsize(ixsize,iysize)
   else
      call prefsize(ixsize,iysize)
      !!call voutput(str(filename,'_',int(a),'x',int(b),'.',device,sep=''))
   endif
   call vinit(device)
   call vsetflush(.false.)
   call vflush()
   call linewidth(w)
!-----------------------------------------------------------------------
!     FILL SOME ARRAYS WITH DATA WE CAN PLOT
   DO i20=1,25
      X(i20)=i20
      Y(i20,1)=i20**2+5.0
      Y(i20,2)=i20*20.0
      Y(i20,3)=(-3.0)*(i20/4.0)**3
   enddo
!-----------------------------------------------------------------------
   f=0.0 !     ZERO OUT OPTION ARRAY
!     SET UP COLOR AND LINETYPE IN OPTION ARRAY
   DO I70=55,NF,2
      F(I70)=mod(i70,7)
      F(I70-1)=mod(i70,7)
   enddo
   f(52)=1
   f(53)=1
!-----------------------------------------------------------------------
   NDP=NUMPTS! number of data points per line
   NDL=3     ! number of data lines
   !C        ! array of strings dimensioned C(3+NUMPTS)
   C(1)='X-AXIS'  !  c(1) : x axis title
   C(2)='Y-AXIS'  !  c(2) : y axis title
   C(3)='TITLE'  !  c(3) : top title
   C(4)='LABEL 1'  !  c(n) : line N-3 legend (optionally used)
   C(5)='LABEL 2'  !  c(n) : line N-3 legend (optionally used)
   C(6)='LABEL 3'  !  c(n) : line N-3 legend (optionally used)
   !NC       ! array of string lengths in c() dimensioned nc(3+NUMPTS)
   DO I60=1,6
      NC(I60)=LEN_TRIM(C(I60))
   enddo
   !f(39)= 0.25
   !f(40)= 0.25
   !f(42)= 3.00
   !f(43)=-1.00
!-----------------------------------------------------------------------
!  INITIALIZE GRAPHICS
   call graph_init(12.0,9.0, 1.00,1.00, 1.0)
   INFINITE: do
      CALL graph(X,Y,NDP,NDL,F,C,NC)
      call vflush()
888   continue
      call readargs(status) ! interactively change NAMELIST group
      if(status.eq.'stop')exit
      call vflush()              ! flush graphics buffers
      call color(7)
      call clear()
      call color(0)
      call vflush()              ! flush graphics buffers
   enddo INFINITE
!-----------------------------------------------------------------------------------------------------------------------------------
999 continue
   call vflush()              ! flush graphics buffers
   call vexit()               ! close up plot package
contains
   subroutine readargs(status)
      character(len=:),intent(out),allocatable :: status
      character(len=256) :: line
      character(len=256) :: answer
      integer            :: lun
      integer            :: ios
      status=''
      write(*,'(a)')'args>> "." to run, "stop" to end, "show" to show keywords'
      do
         write(*,'(a)',advance='no')'args>>'
         read(*,'(a)')line
         if(line(1:1).eq.'!')cycle
         select case(line)
          case('.')
            exit
          case('show')
            write(*,*)'SO FAR'
            write(*,nml=args)
            !! something where you could restrict nml output to just listed names would be nice
            !!write(*,nml=args)['A','H']
            !!write(*,nml=*NML)args['A','H']
          case('sh')
             call execute_command_line('bash')
          case('read')
             write(*,'(a)',advance='no')'filename:'
             read(*,'(a)',iostat=ios)answer
             if(ios.ne.0)exit
             open(file=answer,iostat=ios,newunit=lun)
             if(ios.ne.0)exit
             read(lun,args,iostat=ios)
             close(unit=lun,iostat=ios)
          case('stop')
            status='stop'
            exit
          case('write')
             write(*,'(a)',advance='no')'filename:'
             read(*,'(a)',iostat=ios)answer
             if(ios.ne.0)exit
             open(file=answer,iostat=ios,newunit=lun)
             if(ios.ne.0)exit
             write(lun,args,iostat=ios)
             close(unit=lun,iostat=ios)
          case default
            UPDATE: block
               character(len=:),allocatable :: intmp
               character(len=256)  :: message
               integer :: ios
               intmp='&ARGS '//trim(line)//'/'
               read(intmp,nml=args,iostat=ios,iomsg=message)
               if(ios.ne.0)then
                  write(*,*)'ERROR:',trim(message)
               endif
            endblock UPDATE
         end select
      enddo
   end subroutine readargs
end program demo_graph


PROGRAM riemann

    USE mod_euler_flux_jacobian
    USE mod_constants
    USE mod_thermodynamics
    USE mod_numerical_fluxes

    USE mod_write_vtk

    IMPLICIT NONE

    INTEGER :: i , j ,k                           ! general iteration variables
    INTEGER :: istat                                !
    LOGICAL :: test                                 ! general test variable
    CHARACTER(len=32) :: arg                        ! command line argument
    INTEGER :: count                                ! number of CL arguments
    INTEGER, PARAMETER :: n_params = 11             ! number of params in config file
    LOGICAL, DIMENSION(n_params) :: is_parsed = .FALSE.    ! check if every param has been parsed

    ! simulation parameters to be parsed in the config file
    REAL(dp_kind) :: t_final, dt                     ! total time and delta time between writes
    REAL(dp_kind), DIMENSION(4) :: p1, p2, p3, p4    ! initial condition in quadrants

    INTEGER(sh_kind) :: wr                           ! write data to vtk file
    CHARACTER(len=24) :: dirname, outname           ! folder and file where to write results

    REAL(dp_kind) :: CFL                            ! CFL

    ! simulation variables
    REAL(dp_kind), ALLOCATABLE, DIMENSION(:,:,:) :: w0   ! matrix containing all variables
    REAL(dp_kind) :: lambda_x, lambda_Y             ! maximum eigenvalue for F and G

    REAL(dp_kind), ALLOCATABLE, DIMENSION(:,:,:) :: F,G  ! flux matrices

    ! time related variables
    REAL(dp_kind) :: t_curr                         ! current time
    REAL(dp_kind) :: dt_cfl                         ! delta time given by CFL condition
    REAL(dp_kind) :: act_dt                         ! actual delta time
    REAL(dp_kind) :: t2next_w                       ! time to next write
    REAL cpu_time_begin, cpu_time_end               ! time elapsed in computations
    LOGICAL :: writestep                            ! write solution file at current step
    INTEGER :: i_step = 0                           ! count step

    ! start parsing input file
    count = command_argument_count()

    IF (count < 1 ) THEN
        PRINT*,'count = ',count
        WRITE(*,*) 'Wrong number of input parameters... Exiting'
        STOP
    END IF

    CALL get_command_argument(1, arg)

    WRITE (*,*) CHAR(10),'Using configuration file: ',TRIM(arg), CHAR(10)
    CALL parse_file(arg)

    ! test if all simulation required parameters have been correctly parsed
    IF (ALL(is_parsed)) THEN
        PRINT *, CHAR(10),'All arguments have been parsed',CHAR(10)
    ELSE
        PRINT *, CHAR(10),'NOT All arguments have been parsed... Exiting',CHAR(10)
        STOP
    END IF

    ! test if folder for results exists and create if necessary
    IF (wr == 1) THEN
        INQUIRE(FILE='./'//TRIM(dirname)//'/.', EXIST=test)

        IF (test) THEN
            PRINT *, CHAR(10)//'Directory '//TRIM(dirname)//' exists...'//CHAR(10)
        ELSE
            PRINT *, CHAR(10)//'Directory '//TRIM(dirname)//' does not exist. Creating...'//CHAR(10)
            CALL execute_command_line('mkdir -p '//TRIM(dirname))
        END IF
    END IF

    ! we want to round up to next even integer (if n is odd)
    IF (num_cells > (num_cells/2)*2 ) THEN
        num_cells = num_cells+1
    END IF
    half_cells = num_cells/2

    ! compute cell dimension
    Dx = 1.0 / REAL(num_cells)
    Dy = Dx

    ! allocate memory for solution
    ALLOCATE (w0(num_cells,num_cells,nvar),STAT=istat)

    ALLOCATE (F(1:num_cells+1,1:num_cells,4),STAT=istat)
    ALLOCATE (G(1:num_cells,1:num_cells+1,4),STAT=istat)

    IF (istat /= 0) THEN
        PRINT*, "Failed to allocate variables"
        PRINT*, "Error code: ", istat
        PRINT*, "Exiting..."
        STOP
    END IF

    !allocate memory for point coordinatee
    ALLOCATE (x(0:num_cells,0:num_cells,0:0),STAT=istat)
    ALLOCATE (y(0:num_cells,0:num_cells,0:0),STAT=istat)
    ALLOCATE (z(0:num_cells,0:num_cells,0:0),STAT=istat)

    DO k=0, 0
        DO j=0, num_cells
            DO i=0, num_cells
                x(i, j, k) = i*Dx
                y(i, j, k) = j*Dx
            END DO
        END DO
    END DO

    z = 0.0

    ! Intialize known variables
    ! 1
    w0(half_cells+1:num_cells,half_cells+1:num_cells,i_rho) = p1(i_rho)
    w0(half_cells+1:num_cells,half_cells+1:num_cells,i_u)   = p1(i_u)
    w0(half_cells+1:num_cells,half_cells+1:num_cells,i_v)   = p1(i_v)
    w0(half_cells+1:num_cells,half_cells+1:num_cells,i_P)   = p1(i_P)
    ! 2
    w0(1:half_cells,half_cells+1:num_cells,i_rho) = p2(i_rho)
    w0(1:half_cells,half_cells+1:num_cells,i_u)   = p2(i_u)
    w0(1:half_cells,half_cells+1:num_cells,i_v)   = p2(i_v)
    w0(1:half_cells,half_cells+1:num_cells,i_P)   = p2(i_P)
    ! 3
    w0(1:half_cells,1:half_cells,i_rho) = p3(i_rho)
    w0(1:half_cells,1:half_cells,i_u)   = p3(i_u)
    w0(1:half_cells,1:half_cells,i_v)   = p3(i_v)
    w0(1:half_cells,1:half_cells,i_P)   = p3(i_P)
    ! 4
    w0(half_cells+1:num_cells,1:half_cells,i_rho) = p4(i_rho)
    w0(half_cells+1:num_cells,1:half_cells,i_u)   = p4(i_u)
    w0(half_cells+1:num_cells,1:half_cells,i_v)   = p4(i_v)
    w0(half_cells+1:num_cells,1:half_cells,i_P)   = p4(i_P)

    ! write conservative variables
    CALL conservatives(w0)

    ! compute auxiliary variables (internal energy, speed of sound, schieren)
    CALL auxiliaries(w0)

    ! write first output file
    IF (wr == 1) THEN
        CALL write_vtk(w0,dirname,outname,i_step)
    END IF

    ! start computation
    t_curr = 0.0d0
    t2next_w = dt
    writestep = .FALSE.

    DO WHILE (t_curr <= t_final)

        ! CFL computation
        lambda_x = max_eig(w0(:,:,i_u),w0(:,:,i_c))
        lambda_y = max_eig(w0(:,:,i_v),w0(:,:,i_c))

        dt_cfl = CFL*(Dx/lambda_x+Dy/lambda_y)
        !dt_cfl = CFL*min(Dx/lambda_x,Dy/lambda_y)

        IF (dt_cfl < t2next_w) THEN
            ! delta time from CFL smaller than time to next write
            writestep = .FALSE.
            act_dt = dt_cfl
            t2next_w = t2next_w - act_dt
        ELSE
            ! delta time from cfl bigger than time to next write
            writestep = .TRUE.
            act_dt = t2next_w
            t2next_w = dt
        END IF
        ! update time
        t_curr = t_curr + act_dt
        CALL CPU_TIME(cpu_time_begin)

        ! compute fluxes
        ! Godunov split
        !CALL godunov_flux_x(w0,F)
        !CALL godunov_flux_y(w0,G)

        call HLLC_flux_x(w0,F)

        w0(:,:,i_cons) = w0(:,:,i_cons) - act_dt/Dx*(F(2:num_cells+1,:,:)-F(1:num_cells,:,:))

        CALL primitives(w0)
        CALL auxiliaries(w0)

        call HLLC_flux_y(w0,G)

        w0(:,:,i_cons) = w0(:,:,i_cons) - act_dt/Dy*(G(:,2:num_cells+1,:)-G(:,1:num_cells,:))

        CALL primitives(w0)
        CALL auxiliaries(w0)

        !! Strang split
        !call godunov_flux(w0,F,x)
        !
        !w0 = w0 - dt_cfl/(2.0*dx)*(F(1:num_cells,:)-F(0:num_cells-1,:))
        !
        !call godunov_flux(w0,G,y)
        !
        !w0 = w0 - dt_cfl/dy*(G(:,1:num_cells)-G(:,0:num_cells-1))
        !
        !call godunov_flux(w0,F,x)
        !
        !w0 = w0 - dt_cfl/(2.0*dx)*(F(1:num_cells,:)-F(0:num_cells-1,:))

        ! implementazione di controlli Et > Ec rho > 0

        IF (wr == 1 .and. writestep ) THEN
        !IF ( .TRUE. ) THEN
            i_step = i_step + 1
            CALL write_vtk(w0,dirname,outname,i_step)
        END IF

        CALL CPU_TIME(cpu_time_end)

        WRITE(*,111) "t: ", t_curr, "Execution time: ", cpu_time_end - cpu_time_begin, "sec"

    END DO

    DEALLOCATE(w0)

    PRINT*,"End of computation!"

111 FORMAT(1X, A3, 1X, ES13.3, 1X, A16, ES13.3, 1X, A3)

CONTAINS

    SUBROUTINE parse_file(filename)
        IMPLICIT NONE
        CHARACTER(LEN=32),INTENT(IN) :: filename
        CHARACTER(len=100) :: buffer, label
        INTEGER :: pos
        INTEGER, PARAMETER :: fh = 15
        INTEGER :: ios = 0
        INTEGER :: line = 0

        OPEN(fh, file=filename)

        ! ios is negative if an end of record condition is encountered or if
        ! an endfile condition was detected.  It is positive if an error was
        ! detected.  ios is zero otherwise.

        DO WHILE (ios == 0)
            READ(fh, '(A)', iostat=ios) buffer
            IF (ios == 0) THEN
                line = line + 1

                IF (buffer(1:1) == '#') THEN
                    PRINT*, "comment: ",buffer
                    CYCLE
                END IF
                ! Find the first instance of whitespace.  Split label and data.
                pos = SCAN(buffer, '    ')
                label = buffer(1:pos)
                buffer = buffer(pos+1:)

                SELECT CASE (label)
                    CASE ('T')
                        READ(buffer, *, iostat=ios) t_final
                        IF (ios == 0) THEN
                            WRITE(*,101) 'Read T:', t_final
                            is_parsed(1) = .TRUE.
                        ELSE
                            PRINT *, 'Error parsing T'
                        END IF

                    CASE ('dt')
                        READ(buffer, *, iostat=ios) dt
                        IF (ios == 0) THEN
                            WRITE(*,101) 'Read dt:', dt
                            is_parsed(2) = .TRUE.
                        ELSE
                            PRINT *, 'Error parsing dt'
                        END IF

                    CASE ('n')
                        READ(buffer, *, iostat=ios) num_cells
                        IF (ios == 0) THEN
                            WRITE(*,102) 'Read num cells:', num_cells
                            is_parsed(3) = .TRUE.
                        ELSE
                            PRINT *, 'Error parsing num cells'
                        END IF

                    CASE ('p1')
                        READ(buffer, *, iostat=ios) p1
                        IF (ios == 0) THEN
                            WRITE(*,103) 'Read p1:', p1
                            is_parsed(4) = .TRUE.
                        ELSE
                            PRINT *, 'Error parsing p1'
                        END IF

                    CASE ('p2')
                        READ(buffer, *, iostat=ios) p2
                        IF (ios == 0) THEN
                            WRITE(*,103) 'Read p2:', p2
                            is_parsed(5) = .TRUE.
                        ELSE
                            PRINT *, 'Error parsing p2'
                        END IF

                    CASE ('p3')
                        READ(buffer, *, iostat=ios) p3
                        IF (ios == 0) THEN
                            WRITE(*,103) 'Read p3:', p3
                            is_parsed(6) = .TRUE.
                        ELSE
                            PRINT *, 'Error parsing p3'
                        END IF

                    CASE ('p4')
                        READ(buffer, *, iostat=ios) p4
                        IF (ios == 0) THEN
                            WRITE(*,103) 'Read p4:', p4
                            is_parsed(7) = .TRUE.
                        ELSE
                            PRINT *, 'Error parsing p4'
                        END IF

                    CASE ('write')
                        READ(buffer, *, iostat=ios) wr
                        IF (ios==0) THEN
                            WRITE(*,102) 'Read write condition:', wr
                            is_parsed(8) = .TRUE.
                            IF (wr == 0) THEN
                                is_parsed(9:10) = .TRUE.
                            ELSEIF (wr /= 1) THEN
                                wr = 1
                            END IF
                        ELSE
                            PRINT *, 'Error parsing write'
                        END IF
                    CASE ('outdir')
                        READ(buffer, *, iostat=ios) dirname
                        IF (ios==0) THEN
                            WRITE(*, 104) 'Read output directory:', dirname
                            is_parsed(9) = .TRUE.
                        ELSE
                            PRINT *, 'Error parsing output directory'
                        END IF

                    CASE ('outfile')
                        READ(buffer, *, iostat=ios) outname
                        IF (ios==0) THEN
                            WRITE(*, 104) 'Read output filename:', outname
                            is_parsed(10) = .TRUE.
                        ELSE
                            PRINT *, 'Error parsing output filename'
                        END IF
                    CASE ('CFL')
                        READ(buffer, *, iostat=ios) CFL
                        IF (ios==0) THEN
                            WRITE(*, 101) 'Read CFL:', CFL
                            is_parsed(11) = .TRUE.
                        ELSE
                            PRINT *, 'Error parsing output filename'
                        END IF

                    CASE DEFAULT
                        PRINT *, 'Skipping invalid label at line', line
                END SELECT
            END IF
        END DO

101     FORMAT(1X, A25, 3X, ES13.3)
102     FORMAT(1X, A25, 3X, I5)
103     FORMAT(1X, A25, 3X, 4(ES16.6, 2X))
104     FORMAT(1X, A25, 3X, A24)
    END SUBROUTINE parse_file

END PROGRAM riemann


      subroutine mat_set(n, a, nm)

      use eigen_libs_mod
      use mpi
!$    use omp_lib

      implicit none

      integer, intent(in)    :: n, nm
      real(8), intent(out)   :: a(1:nm,*)

      real(8), parameter     :: ZERO= 0.0D0
      real(8), parameter     :: ONE = 1.0D0

      integer                :: COMM, x_COMM, y_COMM
      integer                :: nnod, x_nnod, y_nnod
      integer                :: inod, x_inod, y_inod
      integer                :: iloop_sta, iloop_end
      integer                :: jloop_sta, jloop_end
      integer                :: i, i_1
      integer                :: j, j_1

      call eigen_get_comm (COMM, x_COMM, y_COMM)
      call eigen_get_procs(nnod, x_nnod, y_nnod)
      call eigen_get_id   (inod, x_inod, y_inod)

      jloop_sta = eigen_loop_start(1, x_nnod, x_inod)
      jloop_end = eigen_loop_end  (n, x_nnod, x_inod)
      iloop_sta = eigen_loop_start(1, y_nnod, y_inod)
      iloop_end = eigen_loop_end  (n, y_nnod, y_inod)

      if (iloop_sta <= iloop_end) then
!$OMP PARALLEL DO &
!$OMP& PRIVATE(i,j,i_1,j_1)
         do i_1 = iloop_sta, iloop_end
            i = eigen_translate_l2g(i_1, y_nnod, y_inod)
            do j_1 = jloop_sta, jloop_end
               j = eigen_translate_l2g(j_1, x_nnod, x_inod)
               a(j_1, i_1) = min(i,j)*ONE
            end do
         end do
!$OMP END PARALLEL DO
      end if

      end subroutine  mat_set

program EigenExa
  use eigen_libs_mod
  use mpi
  implicit none
  double precision   init_tick, gen_tick, diag_tick, end_tick
  integer :: n, m, nm, ny, mtype, i, i_inod, ierr
  real(8), pointer :: a(:,:),z(:,:),w(:)
  character(len=10) :: tmp_str
  integer arg_len, status

  call mpi_init_thread( MPI_THREAD_MULTIPLE, i, ierr )
  if (command_argument_count().eq.1) then
     call get_command_argument(1, tmp_str, arg_len, status)
     read(tmp_str, *) n
  else
     write(*,'(A)') "Error: eigen_exa dimension"
     stop
  endif

  call mpi_barrier(mpi_comm_world, ierr)
  init_tick = mpi_wtime()
  call mpi_comm_rank( mpi_comm_world, i_inod, ierr )
  call eigen_init()
  call mpi_barrier(mpi_comm_world, ierr)
  gen_tick = mpi_wtime()
  call eigen_get_matdims( n, nm, ny )
  allocate( a(nm, ny), z(nm, ny), w(n))
  call mat_set( n, a, nm )

  call mpi_barrier(mpi_comm_world, ierr)
  diag_tick = mpi_wtime()
  call eigen_s( n, n, a, nm, w, z, nm, 48, 128, 'A')
  call mpi_barrier(mpi_comm_world, ierr)
  end_tick = mpi_wtime()
  if ( i_inod == 0 ) then
     print *, "Matrix dimension = ", n
     do i = 1, min(100, n)
        print *, i, w(i)
     end do
     print *, "init_time = ", gen_tick - init_tick
     print *, "gen_time = ", diag_tick - gen_tick
     print *, "diag_time = ", end_tick - diag_tick
  end if

  call eigen_free( )
  call MPI_Finalize( ierr )
end program EigenExa


subroutine ssTauLeap2(K,T,Y0,Y,options,info)
    !
    !   Copyright 2016, Viktor Reshiak, All rights reserved.
    !
    !   Purpose
    !   =======
    !   Find solution of a_tau_s stochastic chemical system.
    !
    !
    !   Method
    !   ======
    !   Two-stage split-step Tau-leaping:
    !
    !   IN
    !   ==
    !   K         - number of time points
    !   T         - K-dimensional row vector of time points
    !   Y0        - num_species-dimensional column vector with initial data
    !   options   - (optional) struct with options of the solver
    !    theta    - implicitness parameter
    !    eta1     - implicitness parameter of the ODE solver for the deterministic predictor
    !    eta2     - implicitness parameter of the ODE solver for the deterministic corrector
    !    Jacobian - true if Jacobain is supplied with 'prop' function, false otherwise
    !
    !
    !   OUT
    !   ===
    !   Y            - num_species-by-K solution array. Each row in Y is the solution of the corresponding equation
    !   info         - structure with information about solvers
    !     time       - average time of solver per time step
    !     iter       - average number of nonlinear iterations per time step
    !   dN           - num_reactions-by-K array of Poisson increments (reaction counts)
    !   poissmsr_tau - 2-by-K2 array of driving compound Poisson measure { (t_i,a_i), i = 1,...,K2 }.
    !
    !
    !   Notes
    !   =====
    !   It is assumed that time grid is uniform

    implicit none

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    ! dummy arguments

    integer(kind=4), intent(in)                               :: K
       real(kind=8), intent(in),  dimension(num_species)      :: Y0
       real(kind=8), intent(in),  dimension(K)                :: T
       real(kind=8), intent(out), dimension(:,:), allocatable :: Y

    type(solver_options), intent(in),  optional :: options
    type(solver_info),    intent(out), optional :: info

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    type(solver_options) :: op
    type(solver_info)    :: inf
    type(fsolve_info)    :: fsolve_inf

    real(kind=8)                                       :: tau
    real(kind=8), dimension(num_reactions)             :: theta_c, theta_p
    real(kind=8), dimension(num_reactions)             :: a_tau_p, a_tau_c, a_tau_s, a_buf
    integer,      dimension(num_reactions)             :: dN
    real(kind=8), dimension(num_reactions,num_species) :: Ja
    real(kind=8), dimension(num_species,num_species)   :: eye_N

    real(kind=8), dimension(num_species,num_species)   :: covariance, covariance_old, true_covariance
    real(kind=8), dimension(num_species)               :: mean, mean_old
    real(kind=8), dimension(num_species,num_species)   :: covariance1, covariance2, covariance3
    real(kind=8), dimension(num_species)               :: mean1, mean2, mean3
    real(kind=8), dimension(num_reactions)             :: theta_c1, theta_c2, theta_c3

    integer(kind=8)  :: count1, count2, count_rate
    integer(kind=4)  :: i, skipped
    integer(kind=4)  :: my_thread

    real(kind=8), dimension(num_species,num_species)   :: R1
    real(kind=8), dimension(num_species)               :: pt, true_mean
    integer(kind=4), dimension(num_species)            :: ipiv
    integer(kind=4)                                    :: status, j, kk
    real(kind=8) :: xT

    real ( kind = 8 ), external :: praxis

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    if ( present(options) ) then
        op = options
    else
        op = default_solver_options
    endif

    if ( .not. allocated(Y) ) then
        allocate(Y(num_species,K))
    endif

    tau     = T(2) - T(1)
    theta_c = (/ (op%theta,i=1,num_reactions) /)
    theta_p = 1 - theta_c

    eye_N = 0.d0
    forall(i=1:num_species) eye_N(i,i) = 1.d0

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    my_thread = omp_get_thread_num()+1

    inf%iter     = 0
    inf%residual = 0.d0
    call system_clock(count1)

    mean = Y0
    true_mean = Y0
    covariance = 0.0
    pt = 0.0
    pt(1) = 1.0
    xT = sum(X0)

    mean1 = Y0
    mean2 = Y0
    mean3 = Y0
    covariance1 = 0.0
    covariance2 = 0.0
    covariance3 = 0.0

    i = 2
    skipped = 0
    Y(:,1)  = Y0
    do while (i <= K)
        Ja = propJacobian(Y(:,i-1))
        R1 = eye_N - tau * matmul( nu, Ja )

        call dgesv( num_species, 1, R1, num_species, ipiv, pt, num_species, status )
        do j = 1,num_species
            do kk = 1,num_species
                true_covariance(j,kk) = -xT * pt(j) * pt(kk)
            enddo
            true_covariance(j,j) = xT * pt(j) * ( 1 - pt(j) )
        enddo
        true_mean = xT * pt

        mean_old       = mean
        covariance_old = covariance
        call choose_theta()

!         print*, true_mean
!         print*, mean

        call deterministic_predictor()

        ! stochastic step
        call poissrnd( num_reactions, a_tau_s, dN )
        Y(:,i) = Y(:,i) + matmul( nu, dN - a_tau_s )

        call deterministic_corrector()

        ! update solution (preserve integer states)
        Y(:,i) = Y(:,i-1) + matmul( nu, nint( dN + a_tau_p + a_tau_c - a_tau_s ) )

        call preserve_positivity()

        i = i + 1
        if ( inf%iter == default_fsolve_options%MaxIter ) then
            i = i - 1;
            skipped = skipped + 1
            if ( skipped > K * 0.5 ) then
                print*, 'Solution did not converge!', dN, Y(:,i)
                ! need this for script to keep the execution window active
                print*, 'Press any key'
                read(*,*)
                call exit(0)
            endif
        endif
	enddo

    print '(a3, 3f15.2)', '1) ', mean1
    print '(a3, 3f15.2)', '2) ', mean2
    print '(a3, 3f15.2)', '3) ', mean3
    print*, ' '
    print '(a3, 4f8.4, f15.2)', '1) ', theta_c1, sqrt(residual(covariance1))
    print '(a3, 4f8.4, f15.2)', '2) ', theta_c2, sqrt(residual(covariance2))
    print '(a3, 4f8.4, f15.2)', '3) ', theta_c3, sqrt(residual(covariance3))

    call system_clock(count2, count_rate)
    inf%time     = (count2-count1) / real(count_rate,8)
    inf%residual = inf%residual / (K-1);

    if ( present(info) ) then
        info = inf
    endif

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    contains

    subroutine deterministic_predictor()
        if ( op.eta1 /= 0 ) then
            theta_tau(:,my_thread) =                          theta_p *    op.eta1  * tau
            a_tau_p                = propensities(Y(:,i-1)) * theta_p * (1-op.eta1) * tau
            Y_buf(:,my_thread)     = Y(:,i-1) + matmul( nu,  a_tau_p )

            call fsolve( num_species, num_species, fun, Y(:,i), X0=Y(:,i-1), info=fsolve_inf, Jac=Jac )

            inf%iter     = inf%iter     + fsolve_inf%iter
            inf%residual = inf%residual + fsolve_inf%final_residual

            a_tau_s = propensities(Y(:,i)) * tau
            a_tau_p = a_tau_p + a_tau_s * theta_p * op.eta1
        else
            a_tau_p = propensities(Y(:,i-1)) * theta_p * tau
            Y(:,i)  = Y(:,i-1) + matmul( nu, a_tau_p )
            a_tau_s = propensities(Y(:,i)) * tau
        endif
    end subroutine deterministic_predictor

    subroutine deterministic_corrector()
        if ( op.eta2 /= 0 ) then
            theta_tau(:,my_thread) =                        theta_c *    op.eta2  * tau
            a_tau_c                = propensities(Y(:,i)) * theta_c * (1-op.eta2) * tau
            Y_buf(:,my_thread)     = Y(:,i) + matmul( nu,  a_tau_c )

            call fsolve( num_species, num_species, fun, Y(:,i), X0=Y(:,i-1), info=fsolve_inf, Jac=Jac )

            inf%iter     = inf%iter     + fsolve_inf%iter
            inf%residual = inf%residual + fsolve_inf%final_residual

            a_tau_c = a_tau_c + propensities(Y(:,i)) * theta_c * op.eta2 * tau
        else
            a_tau_c = propensities(Y(:,i)) * theta_c * tau
            Y(:,i)  = Y(:,i) + matmul( nu,  a_tau_c )
        endif
    end subroutine deterministic_corrector

    subroutine preserve_positivity()
        integer(kind=4) :: j, n

        if ( any( Y(:,i) < 0 ) ) then
            do j = 1,num_species
                do while ( Y(j,i)<0 )
                    do n = 1,num_reactions
                        if ( nu(j,n)<0 ) then
                            Y(:,i) = Y(:,i) - nu(:,n)
                        endif
                    enddo
                enddo
            enddo
        endif
    end subroutine preserve_positivity

    subroutine choose_theta()
        real(kind=8) :: residual, temp(2)

        mean_old       = mean1
        covariance_old = covariance1
        if ( op.theta == -1.0 ) then
            a_buf   = relaxRates(Y(:,i-1)) * tau
            theta_c = sqrt(2.d0/a_buf) - 1.d0/a_buf
            where ( a_buf < 2.0 ) theta_c = 0.633975 - 0.0566243 * a_buf
            theta_p = 1.d0 - theta_c
        endif
        call update_mean_covariance(theta_c)
        mean1       = mean
        covariance1 = covariance
        theta_c1    = theta_c

! print '(a,4e15.4)', '1)', theta_c
        mean_old       = mean2
        covariance_old = covariance2
        temp = 0.05
        call fsolve( 1, 1, covariance_norm, temp, info=fsolve_inf)
        theta_c = temp(1)
        mean2       = mean
        covariance2 = covariance
        theta_c2    = theta_c
! print '(a,4e15.4)', '2)', temp(1)
!         if (i==2) then
!             temp = 0.05
!             theta_c = temp(1)
!             temp(1) = theta_c(1)
!             temp(2) = theta_c(3)
!         endif
        mean_old       = mean3
        covariance_old = covariance3
        temp(1) = theta_c1(1)
        temp(2) = theta_c1(3)
        residual = fminunc( 2, covariance_norm_toms, temp )
        theta_c(1) = temp(1)
        theta_c(2) = temp(1)
        theta_c(3) = temp(2)
        theta_c(4) = temp(2)
        mean3       = mean
        covariance3 = covariance
        theta_c3    = theta_c
!         theta_c = (/ 0.036, 0.095, 0.036, 0.095/)
!         where(theta_c>1) theta_c = 0.99
!         where(theta_c<0) theta_c = 0.01
        theta_p  = 1.d0 - theta_c
! print '(a,4e15.4,e15.4)', '3)', theta_c, residual
!         print '(4e10.2)', theta_c

!         if (residual > 1.0 .or. residual < 1.e-9) then
!         print '(i4,e10.2,4e10.2)', i, residual, theta_c
!         print '(i4,e10.2,4e10.2)', i, residual, theta_p
!         endif

    end subroutine choose_theta

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    function covariance_norm_toms(dim_X,X) result(f)
    ! objective function for theta
        integer,      intent(in)                    :: dim_X
        real(kind=8), intent(in), dimension(dim_X ) :: X
        real(kind=8)                                :: f
        real(kind=8)                                :: f2

        real(kind=8), dimension(num_reactions)           :: theta
        real(kind=8), dimension(num_species,num_species) :: dcov
        real(kind=8), dimension(num_species)             :: dmean
        integer(kind=4)                                  :: j, k

        theta(1) = X(1)
        theta(2) = X(1)
        theta(3) = X(2)
        theta(4) = X(2)
        call update_mean_covariance(theta)
        dcov  = covariance - true_covariance
        dmean = mean       - true_mean

        f  = 0.0
        f2 = 0.0
        do j = 1,num_species
            do k = 1,num_species
                f = f + dcov(j,k)**2
            enddo
            f2 = f2 + dmean(j)**2
        enddo
        !f = f + 1000*f2
        !f = f + f2
    end

    subroutine covariance_norm(dim_f,dim_X,X,f)
    ! objective function for theta
        integer,      intent(in)                     :: dim_f, dim_X
        real(kind=8), intent(in),  dimension(dim_X ) :: X
        real(kind=8), intent(out), dimension(dim_f)  :: f

        real(kind=8), dimension(num_reactions)           :: theta
        real(kind=8), dimension(num_species,num_species) :: dcov
        integer(kind=4)                                  :: j, k

        theta = X(1)
        call update_mean_covariance(theta)

        dcov = covariance - true_covariance

        f(1) = 0.0
        do j = 1,num_species
            do k = 1,num_species
                f(1) = f(1) + dcov(j,k)**2
            enddo
        enddo
    end

    subroutine update_mean_covariance(theta)
        real(kind=8), intent(in), dimension(num_reactions) :: theta

        real(kind=8), dimension(num_species)               :: temp1
        real(kind=8), dimension(num_reactions)             :: temp2
        real(kind=8), dimension(num_species,num_reactions) :: temp3, temp4, nu2, nu3
        real(kind=8), dimension(num_species,num_species)   :: R1, R3, A
        integer                                            :: j

        forall(j=1:num_reactions) nu2(:,j) = nu(:,j) * (1.0-theta(j))
        forall(j=1:num_reactions) nu3(:,j) = nu(:,j) * theta(j)

        R1 = eye_N - op.eta1 * tau * matmul( nu2, Ja )
        R3 = eye_N - op.eta2 * tau * matmul( nu3, Ja )
        call inverse(num_species,R1)
        call inverse(num_species,R3)

        ! propagation matrix
        A = matmul(R3,R1)

        temp1 = matmul(R1,mean_old)
        temp2 = matmul(Ja,temp1)
        temp3 = matmul(R3,nu)
        forall(j=1:num_reactions) temp4(:,j) = temp3(:,j) * temp2(j)
        R1 = tau * matmul(temp4,transpose(temp3))

        ! update mean
        mean = matmul(A,mean_old)

        ! update covariance
        covariance = matmul(A,covariance_old)
        covariance = matmul(covariance,transpose(A))
        covariance = covariance + R1
    end

    function residual(cov) result(f)
        real(kind=8), intent(in), dimension(num_species,num_species) :: cov
        real(kind=8) :: f

        integer :: j,k
        real(kind=8), dimension(num_species,num_species) :: dcov

        dcov = cov - true_covariance

        f  = 0.0
        do j = 1,num_species
            do k = 1,num_species
                f = f + dcov(j,k)**2
            enddo
        enddo
    end

    subroutine fun(dim_f,dim_X,X,f)
    ! objective function for deterministic predictor & corrector
        integer,      intent(in)                     :: dim_f, dim_X
        real(kind=8), intent(in),  dimension(dim_X ) :: X
        real(kind=8), intent(out), dimension(dim_f)  :: f
        integer :: my_thread

        my_thread = omp_get_thread_num()+1

        f = X - Y_buf(:,my_thread) - matmul( nu, propensities(X) * theta_tau(:,my_thread) )
    end subroutine fun

    subroutine Jac(dim_f,dim_X,X,J)
    ! objective Jacobian for deterministic predictor & corrector
        integer,      intent(in)                          :: dim_f, dim_X
        real(kind=8), intent(in),  dimension(dim_X)       :: X
        real(kind=8), intent(out), dimension(dim_f,dim_X) :: J
        integer :: my_thread

        my_thread = omp_get_thread_num()+1

        Ja = propJacobian(X)

        forall(i=1:num_species) Ja(:,i) = Ja(:,i) * theta_tau(:,my_thread)

        J = eye_N - matmul( nu, Ja )
    end subroutine Jac

end subroutine ssTauLeap2


*----------------------------------------------------------------------*
      integer(8) function topo_hash(vtx,topo,xlines,nvtx,nj)
*----------------------------------------------------------------------*
*     get hash function value for arrays defining a contraction
*----------------------------------------------------------------------*
      implicit none

      integer, intent(in) ::
     &     nvtx,nj
      integer(8), intent(in) ::
     &     vtx(nvtx),topo(nvtx,nvtx),xlines(nvtx,nj)

      integer ::
     &     idx, jdx
      integer(8) ::
     &     ifac

      topo_hash = 0
      ifac = 0
      do idx = 1, nvtx
        ifac = ifac + 1
        topo_hash = topo_hash + vtx(idx)/ifac + mod(vtx(idx),ifac)
      end do
      do jdx = 1, nvtx
        do idx = 1, nvtx
          ifac = ifac + 1
          topo_hash = topo_hash + topo(idx,jdx)/ifac
     &                + mod(topo(idx,jdx),ifac)
        end do
      end do
      do jdx = 1, nj
        do idx = 1, nvtx
          ifac = ifac + 1
          topo_hash = topo_hash + xlines(idx,jdx)/ifac
     &                + mod(xlines(idx,jdx),ifac)
        end do
      end do

      end


MODULE conversion
CONTAINS
  !checks
  SUBROUTINE checkrotmat(rotmat)
    REAL, DIMENSION(:) :: rotmat
    identity
  END SUBROUTINE checkrotmat
  SUBROUTINE qcheck(ret, q)
    LOGICAL, INTENT(OUT) :: ret
    REAL, DIMENSION(4), INTENT(IN) :: q
    REAL :: out
    out = q(1)**2 + q(2)**2 + q(3)**2 + q(4)**2
    IF (out > 1.0) THEN
       ret = .FALSE.
    ELSE
       ret = .TRUE.
    END IF
  END SUBROUTINE qcheck

  SUBROUTINE euler2rotmat(rotmat, euler)
    REAL, DIMENSION(3), INTENT(IN) :: euler
    REAL, DIMENSION(3,3), INTENT(OUT) :: rotmat
    REAL, DIMENSION(4) :: q
    !REAL, DIMENSION(3,3) :: r_x, r_y, r_z
    !r_z(1,:) = (/ COS(euler(3)), -SIN(euler(3)), 0 /)
    !r_z(2,:) = (/ SIN(euler(3)),  COS(euler(3)), 0 /)
    !r_z(3,:) = (/ 0, 0, 1 /)
    !r_y(1,:) = (/ COS(euler(2)), 0, SIN(euler(2)) /)
    !r_y(2,:) = (/ 0, 1, 0 /)
    !r_y(3,:) = (/ -SIN(euler(2)), 0, COS(euler(2)) /)
    !r_z(1,:) = (/ 1, 0, 0 /)
    !r_z(2,:) = (/ 0, COS(euler(1)), -SIN(euler(1)) /)
    !r_z(3,:) = (/ 0, SIN(euler(1)), COS(euler(1)) /)
    !rotmat = r_z * r_y * r_x
    call euler2quat(q, euler)
    call quat2rotmat(rotmat, q)
  END SUBROUTINE euler2rotmat
  SUBROUTINE rotmat2euler(euler, rotmat)
    REAL, DIMENSION(3,3), INTENT(IN) :: rotmat
    REAL, DIMENSION(4), INTENT(OUT) :: euler
    REAL, DIMENSION(4) :: q
    !LOGICAL :: singular
    !sy = sqrt( rotmat(1,1)**2 + rotmat(2,1)**2 )
    !singular = sy < 1e-6
    !if (singular == .true.) then
    !   euler(1) = atan2(rotmat(3,2), rotmat(3,3))
    !   euler(2) = atan2(-rotmat(3,1), sy)
    !   euler(3) = atan2(rotmat(2,1), rotmat(1,1))
    !else
    !   euler(1) = atan2(-rotmat(2,3), rotmat(2,2))
    !   euler(2) = atan2(-rotmat(3,1), sy)
    !   euler(3) = 0
    !endif
    call rotmat2quat(q, rotmat)
    call quat2euler(euler, q)
  end subroutine rotmat2euler

  subroutine rotmat2quat(quat, rotmat)
    REAL, DIMENSION(4), INTENT(IN) :: quat
    REAL, DIMENSION(3,3), INTENT(OUT) :: rotmat
  end subroutine rotmat2quat
  subroutine euler2quat(quat, euler)
    REAL, DIMENSION(4), INTENT(IN) :: euler
    REAL, DIMENSION(4), INTENT(OUT) :: quat
  end subroutine rotmat2quat

  subroutine quat2rotmat(rotmat, quat)
    ! r, i, j, k
    ! i am sure there is a better way to implement this
    REAL, DIMENSION(4), INTENT(IN) :: quat
    REAL, DIMENSION(3,3), INTENT(OUT) :: rotmat
    !rotmat(1,:) = (/ 1 - 2*s*(quat(3)**2 + quat(4)**2), 2*s*(q_i
  contains
    subroutine qmul(p,q)
      real, dimension(4) :: p,q
    end subroutine qmul
  end subroutine quat2rotmat
  subroutine quat2euler(euler, quat)
    REAL, DIMENSION(4), INTENT(IN) :: quat
    REAL, DIMENSION(4), INTENT(OUT) :: euler
  end subroutine quat2rotmat

end module conversion