      character*80 input_file,output_file
      dimension c1(6,6),c2(6,6),c3(6,6),c(6,6)

      print *,'input elasticity file = ?'
      read(*,'(a)')input_file
      open(1,file=input_file)

      print *,'output new elasticity file = ?'
      read(*,'(a)')output_file
      open(20,file=output_file,status='new')

      print *,'give weights of the 3 models:'
      read(5,*)w1,w2,w3

      read(1,*)
      read(1,*)ifiso,rho1, dm
      read(1,*)c1(1,1),c1(1,2),c1(1,3),c1(1,4),c1(1,5),c1(1,6),
     &                 c1(2,2),c1(2,3),c1(2,4),c1(2,5),c1(2,6),
     &                         c1(3,3),c1(3,4),c1(3,5),c1(3,6),
     &                                 c1(4,4),c1(4,5),c1(4,6),
     &                                         c1(5,5),c1(5,6),
     &                                                 c1(6,6)

	write(*,*)  ifiso, rho1, c1(1,1)
      read(1,*)
      read(1,*)ifiso,rho2 ,dm
      read(1,*)c2(1,1),c2(1,2),c2(1,3),c2(1,4),c2(1,5),c2(1,6),
     &                 c2(2,2),c2(2,3),c2(2,4),c2(2,5),c2(2,6),
     &                         c2(3,3),c2(3,4),c2(3,5),c2(3,6),
     &                                 c2(4,4),c2(4,5),c2(4,6),
     &                                         c2(5,5),c2(5,6),
     &                                                 c2(6,6)

	write(*,*) ifiso, rho2, c2(1,1)
      read(1,*)
      read(1,*)ifiso,rho3, dm
      read(1,*)c3(1,1),c3(1,2),c3(1,3),c3(1,4),c3(1,5),c3(1,6),
     &                 c3(2,2),c3(2,3),c3(2,4),c3(2,5),c3(2,6),
     &                         c3(3,3),c3(3,4),c3(3,5),c3(3,6),
     &                                 c3(4,4),c3(4,5),c3(4,6),
     &                                         c3(5,5),c3(5,6),
     &                                                 c3(6,6)
	write(*,*)ifiso, rho3, c3(6,6)

      w=w1+w2+w3
      w1=w1/w
      w2=w2/w
      w3=w3/w

      rho=w1*rho1+w2*rho2+w3*rho3

      do 100 i=1,6
      do 100 j=1,6
      c(j,i)=w1*c1(j,i)+w2*c2(j,i)+w3*c3(j,i)
  100 continue

      write(20,'(3f6.2)')w1,w2,w3
      write(20,'(i3,f7.3)')ifiso,rho
      write(20,1001)c(1,1),c(1,2),c(1,3),c(1,4),c(1,5),c(1,6)
      write(20,1002)       c(2,2),c(2,3),c(2,4),c(2,5),c(2,6)
      write(20,1003)              c(3,3),c(3,4),c(3,5),c(3,6)
      write(20,1004)                     c(4,4),c(4,5),c(4,6)
      write(20,1005)                            c(5,5),c(5,6)
      write(20,1006)                                   c(6,6)

 1001 format(    6f9.3)
 1002 format(9x, 5f9.3)
 1003 format(18x,4f9.3)
 1004 format(27x,3f9.3)
 1005 format(36x,2f9.3)
 1006 format(45x, f9.3)

      stop
      end


!> \file discretization.f90
!! Discretization tools for rectangular domains
!! @author Innocent Souopgui
!!
!<

!> Discretization module, define data structures and subroutines for discretization.
!!
!<
module discretization
    use general_constant
    use general_tools
    use debug_tools
implicit none

    !> \brief User defined type for discretization parameters
    !! \details
    !<
    type discretization_param
        integer :: ndim !< number of physical dimension of the problem, 0-3
        !x direction
        real(kind=cp) :: xmin!< minimum coordinate in the x direction of the physical domain
        real(kind=cp) :: xsize!< size of physical domain the in the x direction
        integer :: nx!< number of discretization points in the x direction of the physical domain
        real(kind=cp) :: dx !< space step in the x direction of the physical domain, uniform discretization
        real(kind=cp), dimension(:), pointer :: x => null()!< Coordinates of discretization points in the x direction of the physical domain
        logical :: x_allocated = .false. !< says is the array x has been allocated

        !y direction
        real(kind=cp) :: ymin!< minimum coordinate in the y direction of the physical domain
        real(kind=cp) :: ysize!< size of physical domain the in the y direction
        integer :: ny!< number of discretization points in the y direction of the physical domain
        real(kind=cp) :: dy !< space step in the y direction of the physical domain, uniform discretization
        real(kind=cp), dimension(:), pointer :: y => null()!< Coordinates of discretization points in the y direction of the physical domain
        logical :: y_allocated = .false. !< say is the array y has been allocated

        !z direction
        real(kind=cp) :: zmin!< minimum coordinate in the z direction of the physical domain
        real(kind=cp) :: zsize!< size of physical domain the in the z direction
        integer :: nz!< number of discretization points in the z direction of the physical domain
        real(kind=cp) :: dz !< space step in the z direction of the physical domain, uniform discretization
        real(kind=cp), dimension(:), pointer :: z => null()!< Coordinates of discretization points in the z direction of the physical domain
        logical :: z_allocated = .false. !< says is the array z has been allocated

        !time
        real(kind=cp) :: tmin!< Minimum time
        real(kind=cp) :: tsize!< Size of the simulation window (in s)
        integer :: nt!< Total number of time steps in the simulation
        real(kind=cp) :: dt!< time step, uniform discretization

        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        !                  User defined parameters
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        ! The subdomain A was introduced as the response region in
        ! the sensitivity analysis problem
        ! we expect the user to provide min and size, we will keep min and max
        real(cp) :: A_xmin, A_xmax, A_xsize !< lower boundary and size of A subdomain in x
        real(cp) :: A_ymin, A_ymax, A_ysize !< lower boundary and size of A subdomain in y
        real(cp) :: A_zmin, A_zmax, A_zsize !< lower boundary and size of A subdomain in z

        ! ENO / WENO approximation parameters
        !< @brief left cells count in the stencil for interpolation in
        !< the ENO approximation
        integer :: eno_r
        !< @brief cells count in the stencil for interpolation in ENO approximation
        integer :: eno_k
        integer :: lb, ub !< @brief bounds of the part of array used in computation
        !< @brief extended bounds taken into account extention for
        !< ENO/WENO approximations.
        !>
        integer :: ext_lb, ext_ub
        !< @brief reduced bounds; define the part of the state variable that
        !< goes to the control vector, useful when the boundaries are not
        !< considered as part of the control vector, otherwise, identical
        !< to lb and ub .
        !>
        integer :: red_lb, red_ub
        real(cp), dimension(:), pointer :: &
            eno_ce =>null(),&
            eno_cw =>null(),&
            weno_de=>null(),&
            weno_dw=>null()
    end type discretization_param

    !> discretization parameters, global variable
    type(discretization_param), save :: tg_dp

contains

    !> @brief Load discretization parameters from namelist
    !! @param[in,out] td_dp discretization parameter, the [in] attribute is used to free dynamic memory if necessary
    !! @param[in] pFName name of the namelist file
    !! @details
    !! Most of the time, boundary conditions are provided by and external
    !! process and do not need to be controlled. State variable always included
    !! the boundaries, however, they must be excluded from the control variable
    !! unless they are controlled.
    !! we will possibly add this two more parameters:
    !! param[in] bred reduction in the boundaries
    !! param[in] bext extension in the boundaries for ENO/WENO schemes
    !! @a bred gives the number of grid points
    !! to exclude from the state variable:
    !! @a bred is a two column array that defines the number of
    !! grid points/cells used for the boundary conditions.
    !!
    !! When using schemes like ENO/WENO, the state variable used in computation
    !! is extended by many more grid/cells to match the stencil at the boundaries.
    !! In this case too, the computing variable is an extended state variable.
    !! The extension cells need to be removed to get the actual state variable.
    !! @a bext is is a two column array that defines the number of extension
    !! grid points/cells.
    !!
    !! The number of rows of of @a bred and @a bext is equal to the number
    !! of dimensions of the problem. Those arrays are set up as follows:
    !!   - the row i corresponds to the dimension i (1 for x, 2 for y and 3 for z)
    !!   - the column 1 corresponds to lower bounds
    !!   - the column 2 corresponds to upper bounds
    !! For example,
    !! bred(1,1) is the number of grid points used for the lower boundary in x
    !! bred(1,2) is the number of grid points used for the upper boundary in x
    !! bred(2,1) is the number of grid points used for the lower boundary in y
    !! bred(2,2) is the number of grid points used for the upper boundary in y
    !! bred(3,1) is the number of grid points used for the lower boundary in z
    !! bred(3,2) is the number of grid points used for the upper boundary in z
    !! The same logic applies to @a bext
    !!
    !! There is a strong difference between the two: @a bred is used to get the
    !! control vector from the state vector; @a bext is used to get the actual
    !! state vector from the extended state vector.
    !!
    !<
    subroutine load_discretization(td_dp, pFName)
        integer, parameter:: ip_numnam = 68
        type(discretization_param), intent(in out) :: td_dp
        character(len=*), intent(in) :: pFName
        !integer, dimension(:,:), optional, intent(in) :: bred, bext
        !local variables
        character(len=ip_fnl) :: domainType, timeType, tmp_str
        real(kind=cp), dimension(3) :: coordMin, delta_space, domainSize
        real(kind=cp) :: tMin, delta_t, simulTime
        integer, dimension(3) :: nPoint
        integer :: nDimension, nTime
        logical :: positive_size

        namelist/NAM_discretization/&
        nDimension ,&
        domainType ,&
        timeType   ,&
        coordMin   ,&
        tMin       ,&
        nPoint     ,&
        nTime      ,&
        delta_space,&
        delta_t    ,&
        domainSize ,&
        simulTime

        coordMin = 0.0
        delta_space = 0.0
        domainSize = 0.0
        nPoint = -1
        OPEN(ip_numnam,FILE=pFName,FORM='FORMATTED',STATUS='OLD')
        !If one is going to read many blocs in the same file,
        !it is recommended to rewind
        REWIND(ip_numnam)
        READ(ip_numnam, NAM_discretization)!reading the block
        CLOSE(ip_numnam)

        select case (toLower(timeType))
        case('d')!discrete information
            simulTime = nTime*delta_t
        case('c')!continuous information
            delta_t = simulTime/nTime
        case default
            call debug('domain typ should be:')
            call debug('  - "c" for continuous or "d" for discrete, check the namelist')
            call stop_program('In load_discretization, bad type of domain type, see above ')
        end select
        select case (toLower(domainType))
        case('d')!discrete information
            domainSize = nPoint*delta_space
        case('c')!continuous information
            delta_space = domainSize/(nPoint-1)
        case default
            call stop_program('Bad type of domain type, should be "c" for continuous or "d" for discrete, check the namelist')
        end select
        positive_size = (count(domainSize>0.0)==nDimension)

        if( (.not.positive_size).or.(count(nPoint>0)/=nDimension) )then
            tmp_str = 'The size of delta_space/domainSize and nPoint should correspond to nDimension.'
            tmp_str = trim(tmp_str)//' Negative values or zeroes are not allowed! check the namelist'
            call stop_program(tmp_str)
        end if

        call set_discretization(td_dp, coordMin(1:nDimension)&
        , delta_space(1:nDimension), nPoint(1:nDimension)&
        , tMin, delta_t, nTime)
    end subroutine load_discretization

    !> Set the discretization parameters
    !! @param [in,out] td_dp discretization data structure
    !! @param [in] cMin array giving the minimum coordinate in each dimension of the physical space.
    !! @param [in] delta  array giving the discretization step in each dimension of the physical space.
    !! @param [in] np  array giving the number of discretization points in each dimension of the physical space.
    !! @param [in] tMin starting time of the simulation
    !! @param [in] delta_t time step
    !! @param [in] nTime total number of time steps in the simulation
    !!
    !! \details \a coordmin(i), \a delta(i), \a np(i) correspond to the ith dimension of the physical space.
    !<
    subroutine set_discretization(td_dp, cMin, delta, np, tMin, delta_t, nTime)
        TYPE(discretization_param), INTENT(INOUT) :: td_dp
        REAL(KIND=cp), dimension(:), intent(in) :: cMin, delta
        REAL(KIND=cp), optional, intent(in) :: tMin, delta_t
        INTEGER, dimension(:), intent(in) :: np
        INTEGER, optional, intent(in) :: nTime
        !local variables
        INTEGER :: nDimension, t_nParam

        nDimension = size(cMin)
        if(&
            (nDimension/=size(delta))&
            .or.(nDimension/=size(np)) &
            .or.(nDimension>3)&
            )then
            call stop_program('cMin, delta and np should have the same size, that should be <= 3')
        end if

        td_dp%ndim = nDimension

        if(nDimension>=1)then
            call setCoordinates(td_dp, 'x', np(1), delta(1), cMin(1))
        end if
        if(nDimension>=2)then
            call setCoordinates(td_dp, 'y', np(2), delta(2), cMin(2))
        end if
        if(nDimension>=3)then
            call setCoordinates(td_dp, 'z', np(3), delta(3), cMin(3))
        end if

        t_nParam = count( (/present(tmin),present(delta_t),present(nTime)/) )
        select case(t_nParam)
        case(3)
            call setCoordinates(td_dp, 't', nTime, delta_t, tmin)
        case(0)
        case default
            !call stop_program('set_discretization must be call with exactly none or all of the 3 times parameters')
        end select

    end subroutine set_discretization

    !> @brief load a subdomain from the namelist
    !! @param[in,out] td_dp discretization parameter, the [in] attribute
    !!   is used to free dynamic memory if necessary
    !! @param[in] pFName name of the namelist file
    !! @param[in] dName name of the domain
    !! @details the coordinate of the subdomain are stored in the fields
    !! A_[x,y,z]min, A_[x,y,z]max and A_[x,y,z]size of td_dp
    !<
    subroutine load_subdomain( td_dp, pFName, dName )
        integer, parameter:: fId = 68
        type(discretization_param), intent(in out) :: td_dp
        character(len=*), intent(in) :: pFName, dName
        !local variables
        real(kind=cp), dimension(3) :: xmin, xsize
        character(len=ip_snl) :: domainName, ala_dName
        namelist/NAM_DOMAIN/&
            domainName  ,&
            xmin,&
            xsize
        !
        open(fId,file=pFName,form='FORMATTED',status='OLD')
        domainName = "{#}@"
        ala_dName = TRIM(dName)
        call uppercase(ala_dName)
        do while(domainName.ne.ala_dName)
            read(fId, NAM_DOMAIN)!reading the block
            call uppercase(domainName)
            call debug(domainName, "In load_subdomain, found varName", tag=dALLWAYS)
        end do
        close(fId)
        if(td_dp%ndim>=1)then
            td_dp%A_xmin = xmin(1)
            td_dp%A_xmax = xmin(1)+xsize(1)
            td_dp%A_xsize = xsize(1)
        end if
        !
        if(td_dp%ndim>=2)then
            td_dp%A_ymin = xmin(2)
            td_dp%A_ymax = xmin(2)+xsize(2)
            td_dp%A_ysize = xsize(2)
        end if
        !
        if(td_dp%ndim>=2)then
            td_dp%A_zmin = xmin(2)
            td_dp%A_zmax = xmin(2)+xsize(2)
            td_dp%A_zsize = xsize(2)
        end if
    end subroutine load_subdomain

    !> @brief load the eno parameters from the namelist
    !! @param[in,out] td_dp discretization parameter, the [in] attribute
    !!   is used to free dynamic memory if necessary
    !! @param[in] pFName name of the namelist file
    !<
    subroutine load_enoWeno(td_dp, pFName)
        integer, parameter:: ip_fid = 68
        type(discretization_param), intent(in out) :: td_dp
        character(len=*), intent(in) :: pFName
        !local variables
        integer :: il_eno_r, il_eno_k
        namelist/NAM_ENO/&
        il_eno_r, &
        il_eno_k

        open(ip_fid,file=pFName,form='formatted',status='old')
        !If one is going to read many blocs in the same file, it is recommended to rewind
        rewind(ip_fid)
        read(ip_fid, NAM_ENO)!reading the block
        close(ip_fid)

        td_dp%eno_r  = il_eno_r
        td_dp%eno_k  = il_eno_k
        td_dp%ext_lb = td_dp%lb - td_dp%eno_k!+1
        td_dp%ext_ub = td_dp%ub + td_dp%eno_k

        !eno multipliers for east boundaries
        if (associated(td_dp%eno_ce)) deallocate(td_dp%eno_ce)
        allocate( td_dp%eno_ce(0:td_dp%eno_k-1) )
        td_dp%eno_ce = eno_multipliers(td_dp%eno_r, td_dp%eno_k)

        !eno multipliers for west boundaries
        if (associated(td_dp%eno_cw)) deallocate(td_dp%eno_cw)
        allocate( td_dp%eno_cw(0:td_dp%eno_k-1) )
        td_dp%eno_cw = eno_multipliers(td_dp%eno_r-1, td_dp%eno_k)

        !weno parameter d
        call weno_compute_d(td_dp)
    end subroutine load_enoWeno

    !> Set the coordinates of the discretization points in the \a dir direction of the physical domain or in the time domain
    !! @param [in,out] td_dp discretization data structure, the [in] attribute is used to free dynamic memory if necessary
    !! @param [in] axis dimension where the coordinates are needed
    !! @param [in] n number of discrete coordinates along the axis @a axis
    !! @param [in] delta discretization step along the axis @a axis
    !! @param [in] minCoord minimum coordinate along the axis @a axis
    !!
    !! \details dir should be :
    !! - 'x' or 'X' for the x axis of the physical domain
    !! - 'y' or 'Y' for the Y axis of the physical domain
    !! - 'z' or 'Z' for the Z axis of the physical domain
    !! - 't' or 'T' for the T axis
    !<
    subroutine setCoordinates(td_dp, axis, n, delta, minCoord)
        TYPE(discretization_param), INTENT(INOUT) :: td_dp
        character(len=1), intent(in) :: axis
        INTEGER, INTENT(IN) :: n
        REAL(cp), INTENT(IN) :: delta
        REAL(cp), OPTIONAL, INTENT(IN) :: minCoord
        !local variables
        REAL(cp), DIMENSION(:), POINTER :: coords
        integer :: i

        if((n<0).or.(delta<0))then
        call stop_program('Bad discretization parameters in the dimension '//axis//'. Check the namelist')
        end if
        if(toLower(axis)/='t')then
        allocate(coords(n))
        do i = 1,n
            coords(i) = minCoord + real(i-1,cp)*delta
        end do
        end if
        select case(toLower(axis))
        case('x')
            if (td_dp%x_allocated) deallocate(td_dp%x)
            td_dp%x => coords
            td_dp%x_allocated = .TRUE.
            td_dp%xmin = minCoord
            td_dp%xSize= (n-1)*delta
            td_dp%nx = n
            td_dp%dx = delta
        case('y')
            if (td_dp%y_allocated) deallocate(td_dp%y)
            td_dp%y => coords
            td_dp%y_allocated = .TRUE.
            td_dp%ymin = minCoord
            td_dp%ySize= (n-1)*delta
            td_dp%ny = n
            td_dp%dy = delta
        case('z')
            if (td_dp%z_allocated) deallocate(td_dp%z)
            td_dp%z => coords
            td_dp%z_allocated = .TRUE.
            td_dp%zmin = minCoord
            td_dp%zSize= (n-1)*delta
            td_dp%nz = n
            td_dp%dz = delta
        case('t')
            td_dp%tmin = minCoord
            td_dp%tsize = n*delta
            td_dp%nt = n
            td_dp%dt = delta
        case default
            deallocate(coords)
            call stop_program("Bad dimension; can set coordinates only in the physical dimension x, y and z ")
        end select
    end subroutine setCoordinates

    !> @brief compute multipliers for approximation of boundaries values
    !> in ENO schemes
    !! @param [in] id_r left cells count in the stencil, relative to
    !!  the cell for which approximation is needed
    !! @param [in] id_k cells count in the stencil
    !! @details
    !! When calling this procedure, you know what you are doing.
    !! It is not harmful, but it was design only for 1D problem
    !! When solving problems in more than 1 dimension, make sure that it adapts
    !! to your case
    !<
    function eno_multipliers(id_r, id_k) result(rla_ce)
        integer, intent(in) :: id_r, id_k
        real(kind=cp), dimension(0:id_k-1) :: rla_ce

        select case (id_k)
            case(1)
                select case (id_r)
                    case(-1)
                        rla_ce = real((/ 1. /), cp)
                    case(0)
                        rla_ce = real((/ 1. /), cp)
                end select
            case(2)
                select case (id_r)
                    case(-1)
                        rla_ce = real((/  3./2, -1./2 /), cp)
                    case(0)
                        rla_ce = real((/  1./2,  1./2 /), cp)
                    case(1)
                        rla_ce = real((/ -1./2,  3./2 /), cp)
                end select
            case(3)
                select case (id_r)
                    case(-1)
                        rla_ce = real((/ 11./6, -7./6,  1./3 /), cp)
                    case(0)
                        rla_ce = real((/  1./3,  5./6, -1./6 /), cp)
                    case(1)
                        rla_ce = real((/ -1./6,  5./6,  1./3 /), cp)
                    case(2)
                        rla_ce = real((/  1./3, -7./6, 11./6 /), cp)
                end select
            case(4)
                select case (id_r)
                    case(-1)
                        rla_ce = real((/ 25./12, -23./12,  13./12,  -1./4 /), cp)
                    case(0)
                        rla_ce = real((/   1./4,  13./12,  -5./12,  1./12 /), cp)
                    case(1)
                        rla_ce = real((/ -1./12,   7./12,   7./12, -1./12 /), cp)
                    case(2)
                        rla_ce = real((/  1./12,  -5./12,  13./12,   1./4 /), cp)
                    case(3)
                        rla_ce = real((/  -1./4,  13./12, -23./12, 25./12 /), cp)
                end select
            case(5)
                select case (id_r)
                    case(-1)
                        rla_ce = real((/ 137./60, -163./60, 137./60,  -21./20,    1./5 /), cp)
                    case(0)
                        rla_ce = real((/    1./5,   77./60, -43./60,   17./60,  -1./20 /), cp)
                    case(1)
                        rla_ce = real((/  -1./20,    9./20,  47./60,  -13./60,   1./30 /), cp)
                    case(2)
                        rla_ce = real((/   1./30,  -13./60,  47./60,    9./20,  -1./20 /), cp)
                    case(3)
                        rla_ce = real((/  -1./20,   17./60, -43./60,   77./60,    1./5 /), cp)
                    case(4)
                        rla_ce = real((/    1./5,  -21./20, 137./60, -163./60, 137./60 /), cp)
                end select
            case(6)
                select case (id_r)
                    case(-1)
                        rla_ce = real((/ 49./20, -71./20,   79./20, -163./60,  31./30,  -1./6 /), cp)
                    case(0)
                        rla_ce = real((/   1./6,  29./20,  -21./20,   37./60, -13./60,  1./30 /), cp)
                    case(1)
                        rla_ce = real((/ -1./30,  11./30,   19./20,  -23./60,   7./60, -1./60 /), cp)
                    case(2)
                        rla_ce = real((/  1./60,  -2./15,   37./60,   37./60,  -2./15,  1./60 /), cp)
                    case(3)
                        rla_ce = real((/ -1./60,   7./60,  -23./60,   19./20,  11./30, -1./30 /), cp)
                    case(4)
                        rla_ce = real((/  1./30, -13./60,   37./60,  -21./20,  29./20,   1./6 /), cp)
                    case(5)
                        rla_ce = real((/  -1./6,  31./30, -163./60,   79./20, -71./20, 49./20 /), cp)
                end select
            case(7)
                select case (id_r)
                    case(-1)
                    rla_ce = real((/ 363./140 -617./140, 853./140, -2341./420, 667./210, -43./42, 1./7 /), cp)
                    case(0)
                    rla_ce = real((/ 1./7, 223./140, -197./140, 153./140, -241./420, 37./210, -1./42 /), cp)
                    case(1)
                    rla_ce = real((/ -1./42, 13./42, 153./140, -241./420, 109./420, -31./420, 1./105 /), cp)
                    case(2)
                    rla_ce = real((/ 1./105, -19./210, 107./210, 319./420, -101./420, 5./84, -1./140 /), cp)
                    case(3)
                    rla_ce = real((/ -1./140, 5./84, -101./420, 319./420, 107./210, -19./210, 1./105 /), cp)
                    case(4)
                    rla_ce = real((/ 1./105, -31./420, 109./420, -241./420, 153./140, 13./42, -1./42 /), cp)
                    case(5)
                    rla_ce = real((/ -1./42, 37./210, -241./420, 153./140, -197./140, 223./140, 1./7 /), cp)
                    case(6)
                    rla_ce = real((/ 1./7, -43./42, 667./210, -2341./420, 853./140, -617./140, 363./140 /), cp)
                end select
        end select
    end function eno_multipliers

    !> @brief compute WENO paramters for 1D problems
    !! @param [in] td_tp discretization data structure
    !! @details
    !! When calling this procedure, you know what you are doing.
    !! It is not harmful, but it was design only for 1D problem
    !! When solving problems in more than 1 dimension, make sure that it adapts
    !! to your case
    !<
    subroutine weno_compute_d(td_tp)
        !see 2.54
        type(discretization_param), intent(inout) :: td_tp
        integer :: ibr

        if (associated(td_tp%weno_de)) deallocate(td_tp%weno_de)
        allocate( td_tp%weno_de(0:td_tp%eno_k-1) )
        select case(td_tp%eno_k)
            case (1)
                td_tp%weno_de = real( (/ 1. /), cp)
            case (2)
                td_tp%weno_de = real( (/ 2./3, 1./3 /), cp)
            case (3)
                td_tp%weno_de = real( (/ 3./10, 3./5, 1./10 /), cp)
        end select
        if (associated(td_tp%weno_dw)) deallocate(td_tp%weno_dw)
        allocate( td_tp%weno_dw(0:td_tp%eno_k-1) )
        !symmetric computation for weno_dw
        do ibr = 0, td_tp%eno_k-1
            td_tp%weno_dw(ibr) = td_tp%weno_dw(td_tp%eno_k - 1 - ibr)
        end do
    end subroutine weno_compute_d

    !> Print the discretization parameters
    !! @param [in] td_dp discretization data structure
    !<
    subroutine print_discretization_param(td_dp)
        type(discretization_param), intent(in) :: td_dp

        call debug('Printing discretization parameters ', tag=dALLWAYS)
        if(td_dp%ndim>=1)then
            call debug(td_dp%xmin, 'xmin', tag=dALLWAYS)
            call debug(td_dp%nx, 'nx', tag=dALLWAYS)
            call debug(td_dp%xSize, 'xSize', tag=dALLWAYS)
            call debug(td_dp%dx, 'delta_x', tag=dALLWAYS)
        end if
        if(td_dp%ndim>=2)then
            call debug(td_dp%ymin, 'ymin', tag=dALLWAYS)
            call debug(td_dp%ny, 'ny', tag=dALLWAYS)
            call debug(td_dp%ySize, 'ySize', tag=dALLWAYS)
            call debug(td_dp%dy, 'delta_y', tag=dALLWAYS)
        end if
        if(td_dp%ndim>=3)then
            call debug(td_dp%zmin, 'zmin', tag=dALLWAYS)
            call debug(td_dp%nz, 'nz', tag=dALLWAYS)
            call debug(td_dp%zSize, 'zSize', tag=dALLWAYS)
            call debug(td_dp%dz, 'delta_z', tag=dALLWAYS)
        end if

        call debug(td_dp%tmin, 'tmin', tag=dALLWAYS)
        call debug(td_dp%nt, 'nt', tag=dALLWAYS)
        call debug(td_dp%tSize, 'tSize', tag=dALLWAYS)
        call debug(td_dp%dt, 'delta_t', tag=dALLWAYS)
        call debug('-----------------------------------', tag=dALLWAYS)
    end subroutine print_discretization_param

end module discretization


module poly1
contains
  real function foo(q)
    != unit m :: q
    ! unit for r is determined through constraint-solving
    real :: q, r
    foo = sqr(r) + sqr(q)
  end function foo

  function mul(a,b)
    != unit 'a 'b :: mul
    != unit 'a :: a
    != unit 'b :: b
    real :: a, b, mul
    mul = a * b
  end function mul

  function sqr(x)
    != unit 'c ** 2 :: sqr
    != unit 'c :: x
    ! unit for y determined through constraint-solving
    real :: x, y, sqr

    y = mul(x,x)
    sqr = y
  end function sqr
end module poly1


subroutine output(matrix,matrix_rows,file_unit_specifier)
	implicit none!all variables must be declared
	integer(4),intent(in)::file_unit_specifier!this is the amount of rows that the matrix has at a certain moment
	integer(4)::i=0!first auxiliary index for the matrix
	integer(4)::j=0!second auxiliary index for the matrix
	integer(4),intent(inout)::matrix_rows!this is the amount of rows that the matrix has at a certain moment
	integer(4),intent(inout)::matrix(matrix_rows,9)!all the number cells are here
	do j=1,9
		do i=1,matrix_rows
			write(file_unit_specifier,*) dble(i)-5.d-1,dble(j)-5.d-1,matrix(i,j)!writing the matrix to file
		end do
	end do
	write(*,*) 'set cbrange [0:9]'!this is necessary to force gnuplot to show the message
	write(*,*) 'set palette defined ( 0.0 "#FFFFFF", 1.0 "#FF0000", 2.0 "#BF3F00", 3.0 "#7F7F00", 4.0 "#3FBF00", 5.0 "#00FF00", 6.0 "#00BF3F", 7.0 "#007F7F", 8.0 "#003FBF", 9.0 "#0000FF" )'!this is necessary to force gnuplot to show the message
	write(*,*) 'set view map'!this is necessary to force gnuplot to show the message
	write(*,*) "plot 'matrix_output.dat' u 1:2:3 with image, 'matrix_output.dat' u 1:2:(strcol(3)) w labels"!this is necessary to force gnuplot to show the message
	return
end subroutine output


!******************************************************************************
!* Dual Number Automatic Differentiation (DNAD) of Fortran Codes
!* -------------------------------------------------------------
!* COPYRIGHT (c) Wenbin Yu, All rights reserved, you are free to copy,
!* modify or translate this code to other languages such as c/c++. If
!* you find a bug please let me know through wenbinyu.heaven@gmail.com. If
!* you added new functions and want to share with others, please let me know too.
!* You are welcome to share your successful stories with us through
!* http://groups.google.com/group/hifi-comp.
!******************************************************************************
!* Simple Instruction:
!*---------------------
!* This is the header file: define the interface needed for overloading intrinsic
!* functions and operators.  This file should put in the same folder as dnad.f90.
!* If a function or operation is not defined (unlikely), you need to create a
!* corresponding interface in this file (DNADHeaders.f90) and a corresponding
!* function/subroutine in DNAD.f90.
!*********************************************************************************
!* Acknowledgements
!----------------------
!* The development of DNAD is supported, in part, by the Chief Scientist
!* Innovative Research Fund at AFRL/RB WPAFB, and by Department of Army
!* SBIR (Topic A08-022) through Advanced Dynamics Inc. The views and
!* conclusions contained herein are those of the authors and should not be
!* interpreted as necessarily representing the official policies or endorsement,
!* either expressed or implied, of the funding agency.
!*********************************************************************************

!******** Interfaces for operator overloading
    PUBLIC ASSIGNMENT (=)
    INTERFACE ASSIGNMENT (=)
        MODULE PROCEDURE ASSIGN_DI_D  ! dual=integer, ELEMENTAL
        MODULE PROCEDURE ASSIGN_DR_D  ! dual=real, ELEMENTAL
        MODULE PROCEDURE ASSIGN_DS_D  ! dual=integer, ELEMENTAL
        MODULE PROCEDURE ASSIGN_ID_D  ! integer=dual, ELEMENTAL

!It is found out that compilers will know how to assign a scalar to vectors and matrices
!if the assignment is defined for assigning a scalar to a dual number. Hence it
!is unnecessary to define such assignment overloadings.

    END INTERFACE

    PUBLIC OPERATOR (+)
    INTERFACE OPERATOR (+)
        MODULE PROCEDURE ADD_D_D   ! +dual number, ELEMENTAL
        MODULE PROCEDURE ADD_DD_D  ! dual+ dual, ELEMENTAL
        MODULE PROCEDURE ADD_DI_D  ! dual+ integer, ELEMENTAL
        MODULE PROCEDURE ADD_DR_D  ! dual+ real, ELEMENTAL
        MODULE PROCEDURE ADD_DS_D  ! dual+ single, ELEMENTAL
        MODULE PROCEDURE ADD_ID_D  ! integer+dual, ELEMENTAL
        MODULE PROCEDURE ADD_RD_D  ! real+ dual, ELEMENTAL
        MODULE PROCEDURE ADD_SD_D  ! single+dual, ELEMENTAL
!It is found out that these overloads also cover the cases when one of the operand is a matrix or vector.
!Of course, if both operands are vectors or matrices, they should be of the same shape
    END INTERFACE

    PUBLIC OPERATOR (-)
    INTERFACE OPERATOR (-)
        MODULE PROCEDURE MINUS_D_D   ! negate a dual number,ELEMENTAL
        MODULE PROCEDURE MINUS_DD_D  ! dual -dual,ELEMENTAL
        MODULE PROCEDURE MINUS_DI_D  ! dual-integer,ELEMENTAL
        MODULE PROCEDURE MINUS_DR_D  ! dual-real,ELEMENTAL
        MODULE PROCEDURE MINUS_DS_D  ! dual-single,ELEMENTAL
        MODULE PROCEDURE MINUS_ID_D  ! integer-dual,ELEMENTAL
        MODULE PROCEDURE MINUS_RD_D  ! real-dual,ELEMENTAL
        MODULE PROCEDURE MINUS_SD_D  ! single-dual,ELEMENTAL
!It is found out that these overloads also cover the cases when one of the operand is a matrix or vector.
!Of course, if both operands are vectors or matrices, they should be of the same shape
    END INTERFACE

    PUBLIC OPERATOR (*)
    INTERFACE OPERATOR (*)
        MODULE PROCEDURE MULT_DD_D    ! dual*dual, ELEMENTAL
        MODULE PROCEDURE MULT_DI_D    ! dual*integer,ELEMENTAL
        MODULE PROCEDURE MULT_DR_D    ! dual*real,ELEMENTAL
        MODULE PROCEDURE MULT_DS_D    ! dual*single,ELEMENTAL
        MODULE PROCEDURE MULT_ID_D    ! integer*dual,ELEMENTAL
        MODULE PROCEDURE MULT_RD_D    ! real*dual,ELEMENTAL
        MODULE PROCEDURE MULT_SD_D    ! single*dual,ELEMENTAL
!It is found out that these overloads also cover the cases when one of the operand is a matrix or vector.
!Of course, if both operands are vectors or matrices, they should be of the same shape
    END INTERFACE

    PUBLIC OPERATOR (/)
    INTERFACE OPERATOR (/)
        MODULE PROCEDURE DIV_DD_D ! dual/dual,ELEMENTAL
        MODULE PROCEDURE DIV_DI_D ! dual/integer, ELEMENTAL
        MODULE PROCEDURE DIV_DR_D ! dual/real,EMENTAL
        MODULE PROCEDURE DIV_DS_D ! dual/single,EMENTAL
        MODULE PROCEDURE DIV_ID_D ! integer/dual, ELEMENTAL
        MODULE PROCEDURE DIV_RD_D ! real/dual, ELEMENTAL
        MODULE PROCEDURE DIV_SD_D ! single/dual, ELEMENTAL
    END INTERFACE

    PUBLIC OPERATOR (**)
    INTERFACE OPERATOR (**)
        MODULE PROCEDURE POW_I_D ! power a dual number to an integer power,ELEMENTAL
        MODULE PROCEDURE POW_R_D ! power a dual number to a real (double precision) power, ELEMENTAL
        MODULE PROCEDURE POW_S_D ! power a dual number to a real (single precision) power, ELEMENTAL
        MODULE PROCEDURE POW_D_D ! power a dual number to a dual power, ELEMENTAL
    END INTERFACE

    PUBLIC OPERATOR (==)
    INTERFACE OPERATOR (==)
        MODULE PROCEDURE EQ_DD_D ! compare two dual numbers, ELEMENTAL
        MODULE PROCEDURE EQ_DI_D ! compare a dual and an integer, ELEMENTAL
        MODULE PROCEDURE EQ_DR_D ! compare a dual and a real, ELEMENTAL
        MODULE PROCEDURE EQ_DS_D ! compare a dual and a single, ELEMENTAL
        MODULE PROCEDURE EQ_ID_D ! compare an integer with a dual number, ELEMENTAL
        MODULE PROCEDURE EQ_RD_D ! compare a real with a dual number, ELEMENTAL
        MODULE PROCEDURE EQ_SD_D ! compare a single with a dual number, ELEMENTAL
    END INTERFACE

    PUBLIC OPERATOR (<=)
    INTERFACE OPERATOR (<=)
        MODULE PROCEDURE LE_DD_D  ! compare two dual numbers, ELEMENTAL
        MODULE PROCEDURE LE_DI_D  ! compare a dual and an integer, ELEMENTAL
        MODULE PROCEDURE LE_DR_D  ! compare a dual and a real,ELEMENTAL
        MODULE PROCEDURE LE_DS_D  ! compare a dual and a single,ELEMENTAL
        MODULE PROCEDURE LE_ID_D ! compare an integer with a dual number, ELEMENTAL
        MODULE PROCEDURE LE_RD_D ! compare a real with a dual number, ELEMENTAL
        MODULE PROCEDURE LE_SD_D ! compare a single with a dual number, ELEMENTAL
    END INTERFACE

    PUBLIC OPERATOR (<)
    INTERFACE OPERATOR (<)
        MODULE PROCEDURE LT_DD_D  !compare two dual numbers, ELEMENTAL
        MODULE PROCEDURE LT_DI_D  !compare a dual and an integer, ELEMENTAL
        MODULE PROCEDURE LT_DR_D  !compare dual with a real, ELEMENTAL
        MODULE PROCEDURE LT_DS_D ! compare <u,up> and a single
        MODULE PROCEDURE LT_ID_D ! compare an integer with a dual number, ELEMENTAL
        MODULE PROCEDURE LT_RD_D ! compare a real with a dual number, ELEMENTAL
        MODULE PROCEDURE LT_SD_D ! compare a single with a dual number, ELEMENTAL
    END INTERFACE

    PUBLIC OPERATOR (>=)
    INTERFACE OPERATOR (>=)
        MODULE PROCEDURE GE_DD_D ! compare two dual numbers, ELEMENTAL
        MODULE PROCEDURE GE_DI_D ! compare dual with integer, ELEMENTAL
        MODULE PROCEDURE GE_DR_D ! compare a dual number with a real number, ELEMENTAL
        MODULE PROCEDURE GE_DS_D ! compare dual with a single, ELEMENTAL
        MODULE PROCEDURE GE_ID_D ! compare an integer with a dual number, ELEMENTAL
        MODULE PROCEDURE GE_RD_D ! compare a real with a dual number, ELEMENTAL
        MODULE PROCEDURE GE_SD_D ! compare a single with a dual number, ELEMENTAL
    END INTERFACE

    PUBLIC OPERATOR (>)
    INTERFACE OPERATOR (>)
        MODULE PROCEDURE GT_DD_D  !compare two dual numbers, ELEMENTAL
        MODULE PROCEDURE GT_DI_D  !compare a dual and an integer, ELEMENTAL
        MODULE PROCEDURE GT_DR_D  !compare dual with a real, ELEMENTAL
        MODULE PROCEDURE GT_DS_D ! compare <u,up> and a single
        MODULE PROCEDURE GT_ID_D ! compare an integer with a dual number, ELEMENTAL
        MODULE PROCEDURE GT_RD_D ! compare a real with a dual number, ELEMENTAL
        MODULE PROCEDURE GT_SD_D ! compare a single with a dual number, ELEMENTAL
    END INTERFACE

    PUBLIC OPERATOR (/=)
    INTERFACE OPERATOR (/=)
        MODULE PROCEDURE NE_DD_D  !compare two dual numbers, ELEMENTAL
        MODULE PROCEDURE NE_DI_D  !compare a dual and an integer, ELEMENTAL
        MODULE PROCEDURE NE_DR_D  !compare dual with a real, ELEMENTAL
        MODULE PROCEDURE NE_DS_D ! compare <u,up> and a single
        MODULE PROCEDURE NE_ID_D ! compare an integer with a dual number, ELEMENTAL
        MODULE PROCEDURE NE_RD_D ! compare a real with a dual number, ELEMENTAL
        MODULE PROCEDURE NE_SD_D ! compare a single with a dual number, ELEMENTAL
    END INTERFACE

!------------------------------------------------
! Interfaces for intrinsic functions overloading
!------------------------------------------------
   PUBLIC ABS
   INTERFACE ABS
        MODULE PROCEDURE ABS_D_D  ! obtain the absolute value of a dual number, ELEMENTAL
   END INTERFACE

   PUBLIC DABS
   INTERFACE DABS
        MODULE PROCEDURE ABS_D_D ! the same as ABS, used for some old fortran commands
   END INTERFACE

   PUBLIC ACOS
   INTERFACE ACOS
        MODULE PROCEDURE ACOS_D_D ! obtain the arccosine of a dual number, ELEMENTAL
   END INTERFACE

   PUBLIC ASIN
   INTERFACE ASIN
        MODULE PROCEDURE ASIN_D_D ! obtain the arcsine of a dual number, ELEMENTAL
   END INTERFACE

   ! Added by Nathan A. Wukie - 2/23/2016
   PUBLIC ATAN
   INTERFACE ATAN
        MODULE PROCEDURE ATAN_D_D ! obtain the arcsine of a dual number, ELEMENTAL
   END INTERFACE

   PUBLIC COS
   INTERFACE COS
        MODULE PROCEDURE COS_D_D ! obtain the cosine of a dual number, ELEMENTAL
   END INTERFACE

   PUBLIC DCOS
   INTERFACE DCOS
        MODULE PROCEDURE COS_D_D ! obtain the cosine of a dual number, ELEMENTAL
   END INTERFACE

!   PUBLIC DOT_PRODUCT
!   INTERFACE DOT_PRODUCT
!        MODULE PROCEDURE DOT_PRODUCT_DD_D ! dot product two dual number vectors
!   END INTERFACE

   PUBLIC EXP
   INTERFACE EXP
        MODULE PROCEDURE EXP_D_D ! obtain the exponential of a dual number, ELEMENTAL
   END INTERFACE

   PUBLIC INT
   INTERFACE INT
        MODULE PROCEDURE INT_D_D ! obtain the integer part of a dual number, ELEMENTAL
   END INTERFACE

   PUBLIC LOG
   INTERFACE LOG
        MODULE PROCEDURE LOG_D_D ! obtain the log of a dual number, ELEMENTAL
   END INTERFACE

   PUBLIC LOG10
   INTERFACE LOG10
        MODULE PROCEDURE LOG10_D_D ! obtain the log of a dual number, ELEMENTAL
   END INTERFACE

   PUBLIC MATMUL
   INTERFACE MATMUL
        MODULE PROCEDURE MATMUL_DD_D     ! matrix multiplies of two dual matrices
        MODULE PROCEDURE MATMUL_DV_D     ! matrix multiplies of a dual matrix with a dual vector
        MODULE PROCEDURE MATMUL_VD_D     ! matrix multiplies of a dual vector with a dual matrix
        MODULE PROCEDURE MATMUL_MV_RD_D  ! matrix-vector :: real-dual
   END INTERFACE

   PUBLIC MAX
   INTERFACE MAX
        MODULE PROCEDURE MAX_DD_D ! obtain the max of from two to four dual numbers, ELEMENTAL
       MODULE PROCEDURE MAX_DI_D ! obtain the max of from a dual number and an integer, ELEMENTAL
       MODULE PROCEDURE MAX_DR_D ! obtain the max of from a dual number and a real, ELEMENTAL
       MODULE PROCEDURE MAX_DS_D ! obtain the max of from a dual number and a real in single precision, ELEMENTAL
       MODULE PROCEDURE MAX_RD_D ! obtain the max of from a real,and a dual number,  ELEMENTAL
   END INTERFACE

   PUBLIC DMAX1
   INTERFACE DMAX1
        MODULE PROCEDURE MAX_DD_D ! obtain the max of from two to four dual numbers, ELEMENTAL
   END INTERFACE

   PUBLIC MAXVAL
   INTERFACE MAXVAL
        MODULE PROCEDURE MAXVAL_D_D ! obtain the maxval  of a dual number vectgor
   END INTERFACE

   PUBLIC MIN
   INTERFACE MIN
        MODULE PROCEDURE MIN_DD_D ! obtain the min of from two to four dual numbers, ELEMENTAL
         MODULE PROCEDURE MIN_DR_D ! obtain the min of a dual and a real, ELEMENTAL
         MODULE PROCEDURE MIN_DS_D ! obtain the min of a dual and a single, ELEMENTAL
   END INTERFACE

   PUBLIC DMIN1
   INTERFACE DMIN1
        MODULE PROCEDURE MIN_DD_D ! obtain the min of from two to four dual numbers, ELEMENTAL
   END INTERFACE

   PUBLIC MINVAL
   INTERFACE MINVAL
        MODULE PROCEDURE MINVAL_D_D ! obtain the maxval  of a dual number vectgor
   END INTERFACE

   PUBLIC NINT
   INTERFACE NINT
        MODULE PROCEDURE NINT_D_D ! Returns the nearest integer to the argument, ELEMENTAL
   END INTERFACE

   PUBLIC SIGN
   INTERFACE  SIGN
     MODULE PROCEDURE  SIGN_DD_D ! SIGN(a,b) with two dual numbers as inputs, the result will be |a| if b%x>=0, -|a| if b%x<0,ELEMENTAL
     MODULE PROCEDURE  SIGN_RD_D ! SIGN(a,b) with a real and a dual, the result will be |a| if b%x>=0, -|a| if b%x<0,ELEMENTAL
   END INTERFACE

   PUBLIC SIN
   INTERFACE SIN
        MODULE PROCEDURE SIN_D_D ! obtain sine of a dual number, ELEMENTAL
   END INTERFACE

   PUBLIC DSIN
   INTERFACE DSIN
        MODULE PROCEDURE SIN_D_D ! obtain sine of a dual number, ELEMENTAL
   END INTERFACE

   PUBLIC SQRT
   INTERFACE SQRT
        MODULE PROCEDURE SQRT_D_D ! obtain the sqrt of a dual number, ELEMENTAL
   END INTERFACE

   PUBLIC SUM
   INTERFACE SUM
        MODULE PROCEDURE SUM_D_D ! sum a dual array
   END INTERFACE


!-----------------------------------------------------------------
! Programmer(s): Daniel R. Reynolds @ SMU
!-----------------------------------------------------------------
! LLNS/SMU Copyright Start
! Copyright (c) 2015, Southern Methodist University and
! Lawrence Livermore National Security
!
! This work was performed under the auspices of the U.S. Department
! of Energy by Southern Methodist University and Lawrence Livermore
! National Laboratory under Contract DE-AC52-07NA27344.
! Produced at Southern Methodist University and the Lawrence
! Livermore National Laboratory.
!
! All rights reserved.
! For details, see the LICENSE file.
! LLNS/SMU Copyright End
! Copyright (c) 2013, Southern Methodist University.
! All rights reserved.
! For details, see the LICENSE file.
!-----------------------------------------------------------------
! Example problem:
!
! The following test simulates a brusselator problem from chemical
! kinetics.  This is an ODE system with 3 components, Y = [u,v,w],
! satisfying the equations,
!    du/dt = a - (w+1)*u + v*u^2
!    dv/dt = w*u - v*u^2
!    dw/dt = (b-w)/ep - w*u
! for t in the interval [0.0, 10.0], with initial conditions
! Y0 = [u0,v0,w0].  We use the initial conditions and parameters
!    u0=3.9,  v0=1.1,  w0=2.8,  a=1.2,  b=2.5,  ep=1.0e-5
! Here, all three solution components exhibit a rapid transient
! change during the first 0.2 time units, followed by a slow and
! smooth evolution.
!
! This program solves a the Fortran ODE test problem using the
! FARKODE interface for the ARKode ODE solver module.
!
! This program uses the IMEX ARK solver; here the
! implicit systems are solved with a modified Newton iteration
! with the ARKDENSE dense linear solver.  The Jacobian routine
! and right-hand side routines come from the file user-supplied
! Jacobian routine.
!
! Output is printed 10 times throughout the defined time interval.
! Run statistics (optional outputs) are printed at the end.
!-----------------------------------------------------------------

!-----------------------------------------------------------------
! Main driver program
!-----------------------------------------------------------------
program driver
  ! Declarations
  implicit none

  ! general problem variables
  integer*8, parameter :: NEQ=3
  real*8,    parameter :: T0=0.d0, Tf=10.d0
  real*8    :: dTout, Tout, Tcur, rtol, atol, rout(6)
  integer   :: it, Nt, ier
  integer*8 :: iout(22)
  real*8, dimension(NEQ) :: y

  ! real/integer parameters to pass through to supplied functions
  !    ipar(1) -> unused
  !    rpar(1) -> "a" parameter
  !    rpar(2) -> "b" parameter
  !    rpar(3) -> "ep" parameter
  integer*8 :: ipar
  real*8    :: rpar(3)

  ! solver parameters
  integer*8 :: order, adapt_method
  real*8    :: nlscoef

  !-----------------------
  ! set some solver parameters
  order = 3          ! 4th order method
  adapt_method = 0   ! PID-controller
  nlscoef = 1.d-2    ! Newton solver tolerance coefficient

  ! time-stepping information
  dTout = (Tf-T0)/10.d0    ! output time interval
  Nt = Tf/dTout + 0.5      ! number of outputs

  ! set initial conditions, problem parameters
  y(1) = 3.9d0     ! u0
  y(2) = 1.1d0     ! v0
  y(3) = 2.8d0     ! w0
  rpar(1) = 1.2d0  ! a
  rpar(2) = 2.5d0  ! b
  rpar(3) = 1.d-5  ! ep

  ! set tolerances according to problem specifications
  atol = 1.d-10
  rtol = 1.d-6

  ! initialize vector module
  call FNVInitS(4, NEQ, ier)
  if (ier < 0) then
     write(0,*) 'Error in FNVInitS = ',ier
     stop
  endif

  ! initialize ARKode solver to use IMEX integrator, scalar tolerances
  call FARKMalloc(T0, y, 2, 1, rtol, atol, &
                  iout, rout, ipar, rpar, ier)
  if (ier < 0) then
     write(0,*) 'Error in FARKMalloc = ',ier
     stop
  endif

  ! set integrator options
  call FARKSetIin('ORDER', order, ier)
  if (ier < 0) then
     write(0,*) 'Error in FARKSetIin = ',ier
     stop
  endif
  call FARKSetRin('NLCONV_COEF', nlscoef, ier)
  if (ier < 0) then
     write(0,*) 'Error in FARKSetIin = ',ier
     stop
  endif
  call FARKSetAdaptivityMethod(adapt_method, 1, 0, 0, ier)
  if (ier < 0) then
     write(0,*) 'Error in FARKSetAdaptMethod = ',ier
     stop
  endif

  ! specify use of dense linear solver
  call FARKDense(NEQ, ier)
  if (ier < 0) then
     write(0,*) 'Error in FARKDense = ',ier
     stop
  endif
  call FARKDenseSetJac(1, ier)
  if (ier < 0) then
     write(0,*) 'Error in FARKDenseSetJac = ',ier
     stop
  endif

  ! Open output stream for results, output comment line
  open(100, file='solution.txt')
  write(100,*) '# t u v w'

  ! output initial condition to disk
  write(100,'(3x,4(es23.16,1x))') T0, y

  ! loop over time outputs
  Tout = T0
  Tcur = T0
  print *, '        t           u           v           w'
  print *, '  ----------------------------------------------------'
  print '(3x,4(es12.5,1x))', Tcur, y
  do it = 1,Nt

     Tout = min(Tout + dTout, Tf)           ! set next output time
     call FARKode(Tout, Tcur, y, 1, ier)    ! call solver
     if (ier < 0) then
        print *, 'Error at step ',it,', FARKode return flag =',ier
        exit
     end if

     ! output current solution
     print '(3x,4(es12.5,1x))', Tcur, y
     write(100,'(3x,4(es23.16,1x))') Tcur, y

  end do
  print *, '  ----------------------------------------------------'
  close(100)

  ! output solver statistics
  print *, '  '
  print *, 'Final Solver Statistics:'
  print '(2(A,i7),A)', '   Internal solver steps =', iout(3), &
       ' (attempted =', iout(6), ')'
  print '(2(A,i7))', '   Total RHS evals:  Fe =', iout(7), &
       ',  Fi =', iout(8)
  print '(A,i7)', '   Total linear solver setups =', iout(9)
  print '(A,i7)', '   Total RHS evals for setting up the linear system =', iout(17)
  print '(A,i7)', '   Total number of Jacobian evaluations =', iout(18)
  print '(A,i7)', '   Total number of Newton iterations =', iout(11)
  print '(A,i7)', '   Total number of nonlinear solver convergence failures =', iout(12)
  print '(A,i7)', '   Total number of error test failures =', iout(10)
  print *, '  '

  ! clean up
  call FARKFree()

end program driver
!-----------------------------------------------------------------

!-----------------------------------------------------------------
! Required subroutines for FARKODE interface
!-----------------------------------------------------------------

subroutine farkifun(t, y, ydot, ipar, rpar, ier)
!-----------------------------------------------------------------
! Implicit portion of the right-hand side of the ODE system
!-----------------------------------------------------------------

  ! Declarations
  implicit none

  ! Arguments
  real*8,    intent(in)  :: t, rpar(3)
  integer*8, intent(in)  :: ipar(1)
  integer,   intent(out) :: ier
  real*8,    intent(in)  :: y(3)
  real*8,    intent(out) :: ydot(3)

  ! temporary variables
  real*8 :: u, v, w, a, b, ep

  ! set temporary values
  a  = rpar(1)
  b  = rpar(2)
  ep = rpar(3)
  u  = y(1)
  v  = y(2)
  w  = y(3)

  ! fill implicit RHS, set success flag
  ydot(1) = 0.d0
  ydot(2) = 0.d0
  ydot(3) = (b-w)/ep
  ier = 0

end subroutine farkifun
!-----------------------------------------------------------------

subroutine farkefun(t, y, ydot, ipar, rpar, ier)
!-----------------------------------------------------------------
! Explicit portion of the right-hand side of the ODE system
!-----------------------------------------------------------------

  ! Declarations
  implicit none

  ! Arguments
  real*8,    intent(in)  :: t, rpar(3)
  integer*8, intent(in)  :: ipar(1)
  integer,   intent(out) :: ier
  real*8,    intent(in)  :: y(3)
  real*8,    intent(out) :: ydot(3)

  ! temporary variables
  real*8 :: u, v, w, a, b, ep

  ! set temporary values
  a  = rpar(1)
  b  = rpar(2)
  ep = rpar(3)
  u  = y(1)
  v  = y(2)
  w  = y(3)

  ! fill explicit RHS, set success flag
  ydot(1) = a - (w+1.d0)*u + v*u*u
  ydot(2) = w*u - v*u*u
  ydot(3) = -w*u
  ier = 0

end subroutine farkefun
!-----------------------------------------------------------------

subroutine farkdjac(neq,t,y,fy,DJac,h,ipar,rpar,wk1,wk2,wk3,ier)
!-----------------------------------------------------------------
! Jacobian computation routine
!-----------------------------------------------------------------

  ! Declarations
  implicit none

  ! Arguments
  real*8,    intent(in)  :: t, h, rpar(3)
  integer*8, intent(in)  :: neq, ipar(1)
  integer,   intent(out) :: ier
  real*8,    intent(in), dimension(neq) :: y, fy, wk1, wk2, wk3
  real*8,    intent(out) :: DJac(neq,neq)

  ! temporary variables
  real*8 :: u, v, w, a, b, ep

  ! set temporary values
  a  = rpar(1)
  b  = rpar(2)
  ep = rpar(3)
  u  = y(1)
  v  = y(2)
  w  = y(3)

  ! fill implicit Jacobian, set success flag
  DJac = 0.d0
  DJac(3,3) = -1.d0/ep
  ier = 0

end subroutine farkdjac
!-----------------------------------------------------------------


!!!=======================================================================================
!!! 2015.04.16: Ksi as a function of epsilon
!!!=======================================================================================
   PROGRAM max_min
   IMPLICIT NONE

   INTEGER (KIND=8),PARAMETER::nJ=13
   REAL (KIND=8),PARAMETER:: Jc=0.4365

   INTEGER (KIND=8) :: i
   REAL (KIND=8),DIMENSION(nJ) :: J,E,M,Cv,Ksi,E2,M2,eps

!!!=======================================================================================
!!!=======================================================================================
   OPEN(unit=12,file='E_av.txt')
   OPEN(unit=13,file='Ksi.dat')

   DO i=1,nJ
      READ(12,*)J(i),E(i),M(i),Cv(i),Ksi(i),E2(i),M2(i)
      eps(i)=abs((J(i)/Jc)-1.)
   END DO

   DO i=1,nJ
      eps(i)=abs((J(i)/Jc)-1.)

      WRITE(13,*)J(i),eps(i),Ksi(i)
   END DO

   CLOSE(12)
   CLOSE(13)

   END PROGRAM max_min


program array_initialization
    implicit none
    integer :: i
    integer, dimension(5) :: A, B, C

    A = 13
    B = [ 2, 3, 5, 7, 11 ]
    C = [ (2**i, i=0,4) ]
    print *, A
    print *, B
    print *, C
end program array_initialization


!==============================================================================!
  subroutine Bicg(mat_a, x, r1, prec, niter, tol, ini_res, fin_res, norm)
!------------------------------------------------------------------------------!
!   Solves the linear systems of equations by a precond. BiCG Method.          !
!------------------------------------------------------------------------------!
!   Allows preconditioning of the system by:                                   !
!     1. Diagonal preconditioning                                              !
!     2. Incomplete Cholesky preconditioning                                   !
!                                                                              !
!   The type of precondtioning is chosen by setting the variable prec to 0     !
!   (for no preconditioning), 1 (for diagonal preconditioning) or 2 (for       !
!   incomplete Cholesky preconditioning)                                       !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use Comm_Mod
  use Matrix_Mod
  use Work_Mod, only: p1 => r_cell_01,  &
                      p2 => r_cell_02,  &
                      q1 => r_cell_03,  &
                      q2 => r_cell_04,  &
                      r2 => r_cell_05
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Matrix_Type) :: mat_a
  real              :: x(-mat_a % pnt_grid % n_bnd_cells :  &
                          mat_a % pnt_grid % n_cells)
  real              :: r1(mat_a % pnt_grid % n_cells)    ! [A]{x}={r1}
  character(len=80) :: prec                              ! preconditioner
  integer           :: niter                             ! number of iterations
  real              :: tol                               ! tolerance
  real              :: ini_res, fin_res                  ! residual
  real, optional    :: norm                              ! normalization
!-----------------------------------[Locals]-----------------------------------!
  integer :: nt, ni, nb
  real    :: alfa, beta, rho, rho_old, bnrm2, error
  integer :: i, j, k, iter, sub
!==============================================================================!

  error = 0.

  nt = mat_a % pnt_grid % n_cells
  ni = mat_a % pnt_grid % n_cells - mat_a % pnt_grid % comm % n_buff_cells
  nb = mat_a % pnt_grid % n_bnd_cells

  !---------------------!
  !   Preconditioning   !
  !---------------------!
  call Prec_Form(mat_a, prec)

  !-----------------------------------!
  !    This is quite tricky point.    !
  !   What if bnrm2 is very small ?   !
  !-----------------------------------!
  if(.not. present(norm)) then
    bnrm2 = Normalized_Residual(ni, mat_a, x(1:nt), r1(1:ni))
  else
    bnrm2 = Normalized_Residual(ni, mat_a, x(1:nt), r1(1:ni), norm)
  end if

  if(bnrm2 < tol) then
    iter = 0
    goto 1
  end if

  !----------------!
  !   r = b - Ax   !
  !----------------!
  call Residual_Vector(ni, mat_a, x(1:nt), r1(1:ni))

  !--------------------------------!
  !   Calculate initial residual   !
  !--------------------------------!
  error = Normalized_Residual(ni, mat_a, x(1:nt), r1(1:ni))

  !---------------------------------------------------------------!
  !   Residual after the correction and before the new solution   !
  !---------------------------------------------------------------!
  ini_res = error

  if(error < tol) then
    iter = 0
    goto 1
  end if

  !----------------------!
  !   Choose initial r   !
  !----------------------!
  do i = 1, ni
    r2(i) = r1(i)
  end do

  !---------------!
  !               !
  !   Main loop   !
  !               !
  !---------------!
  do iter = 1, niter

    !----------------------!
    !    solve Mz  = r     !
    !    solve Mz = r      !
    !   (q instead of z)   !
    !----------------------!
    call Prec_Solve(mat_a, q1, r1(1), prec)
    call Prec_Solve(mat_a, q2, r2(1), prec)

    !-----------------!
    !   rho = (z,r)   !
    !-----------------!
    rho=0.
    do i = 1, ni
      rho = rho+q1(i)*r2(i)
    end do
    call Comm_Mod_Global_Sum_Real(rho)

    if(iter .eq. 1) then
      do i = 1, ni
        p1(i) = q1(i)
        p2(i) = q2(i)
      end do
    else
      beta = rho/rho_old
      do i = 1, ni
        p1(i) = q1(i) + beta*p1(i)
        p2(i) = q2(i) + beta*p2(i)
      end do
    end if

    !-------------!
    !   q = A p   !
    !   q~= A p~  !
    !-------------!
    call Comm_Mod_Exchange_Real(mat_a % pnt_grid, p1)
    call Comm_Mod_Exchange_Real(mat_a % pnt_grid, p2)
    do i = 1, ni
      q1(i) = 0.
      q2(i) = 0.
      do j = mat_a % row(i), mat_a % row(i+1)-1
        k = mat_a % col(j)
        q1(i) = q1(i) + mat_a % val(j) * p1(k)
        q2(i) = q2(i) + mat_a % val(j) * p2(k)
      end do
    end do

    !------------------------!
    !   alfa = (z,r)/(p,q)   !
    !------------------------!
    alfa = 0.0
    do i = 1, ni
      alfa = alfa+p2(i)*q1(i)
    end do
    call Comm_Mod_Global_Sum_Real(alfa)
    alfa = rho/alfa

    !--------------------!
    !   x = x + alfa p   !
    !   r = r - alfa q   !
    !--------------------!
    do i = 1, ni
      x(i)  = x(i)  + alfa*p1(i)
      r1(i) = r1(i) - alfa*q1(i)
      r2(i) = r2(i) - alfa*q2(i)
    end do

    !-----------------------!
    !   Check convergence   !
    !-----------------------!
    if(.not. present(norm)) then
      error = Normalized_Residual(ni, mat_a, x(1:nt), r1(1:ni))
    else
      error = Normalized_Residual(ni, mat_a, x(1:nt), r1(1:ni), norm)
    end if

    if(error < tol) goto 1

    rho_old=rho

  end do     ! iter

1 fin_res = error
  niter = iter

  end subroutine


cBHEADER**********************************************************************
c Copyright (c) 2008,  Lawrence Livermore National Security, LLC.
c Produced at the Lawrence Livermore National Laboratory.
c This file is part of HYPRE.  See file COPYRIGHT for details.
c
c HYPRE is free software; you can redistribute it and/or modify it under the
c terms of the GNU Lesser General Public License (as published by the Free
c Software Foundation) version 2.1 dated February 1999.
c
c $Revision: 1.4 $
cEHEADER**********************************************************************

c-----------------------------------------------------------------------
c Test driver for structured matrix interface (structured storage)
c-----------------------------------------------------------------------

c-----------------------------------------------------------------------
c Standard 7-point laplacian in 3D with grid and anisotropy determined
c as user settings.
c-----------------------------------------------------------------------

      program test

      include 'mpif.h'

      parameter (MAXZONS=4194304)
      parameter (MAXBLKS=32)
      parameter (MAXDIM=3)

      integer             num_procs, myid

      integer             dim
      integer             nx, ny, nz
      integer             Px, Py, Pz
      integer             bx, by, bz
      double precision    cx, cy, cz
      integer             n_pre, n_post
      integer             solver_id
      integer             precond_id

      integer             zero, one
      integer             maxiter, dscgmaxiter, pcgmaxiter
      double precision    tol, convtol

      integer             num_iterations
      double precision    final_res_norm

      integer*8  A
      integer*8  b, b_V
      integer*8  x, x_V
      integer*8  solver
      integer*8  precond
      integer*8  solver_SMG
      integer*8  grid
      integer*8  stencil
      integer*8 bHYPRE_mpicomm
      integer*8 mpi_comm
      integer             symmetric
      integer*8  except
c     ... except is for Babel exceptions, which we shall ignore

      double precision    dxyz(3)
      integer             A_num_ghost(6)
      integer             iupper(3,MAXBLKS), ilower(3,MAXBLKS)
      integer             istart(3), iend(3)
      integer             offsets(3,MAXDIM+1)
      integer             stencil_indices(MAXDIM+1)
      double precision    values((MAXDIM+1)*MAXZONS)
      integer             p, q, r
      integer             nblocks, volume
      integer             i, s, d
      integer             ix, iy, iz, ib
      integer             ierr
      double precision    dtemp
      integer             itemp2
      integer             itemp3
      integer             periodic(3)

      data A_num_ghost   / 0, 0, 0, 0, 0, 0 /
      data zero          / 0 /
      data one           / 1 /
      ierr = 0

c-----------------------------------------------------------------------
c     Initialize MPI
c-----------------------------------------------------------------------

      call MPI_INIT(ierr)
      call MPI_COMM_RANK(MPI_COMM_WORLD, myid, ierr)
      call MPI_COMM_SIZE(MPI_COMM_WORLD, num_procs, ierr)
      mpi_comm = MPI_COMM_WORLD
c     MPI_COMM_WORLD cannot be directly passed through the Babel interface
c     because its byte length is unspecified.
      call bHYPRE_MPICommunicator_CreateF_f( mpi_comm, bHYPRE_mpicomm,
     1     except )

c-----------------------------------------------------------------------
c     Set defaults
c-----------------------------------------------------------------------

      dim = 3

      nx = 10
      ny = 10
      nz = 10

      Px  = num_procs
      Py  = 1
      Pz  = 1

      bx = 1
      by = 1
      bz = 1

      cx = 1.0
      cy = 1.0
      cz = 1.0

      n_pre  = 1
      n_post = 1

      solver_id = 0

      istart(1) = -3
      istart(2) = -3
      istart(3) = -3
      iend(1) = istart(1) + nx - 1
      iend(2) = istart(2) + ny - 1
      iend(3) = istart(3) + nz - 1

c-----------------------------------------------------------------------
c     Check a few things
c-----------------------------------------------------------------------

      if ((Px*Py*Pz) .ne. num_procs) then
         print *, 'Error: Invalid number of processors or topology'
         stop
      endif

      if ((dim .lt. 1) .or. (dim .gt. 3)) then
         print *, 'Error: Invalid problem dimension'
         stop
      endif

      if ((nx*ny*nz) .gt. MAXZONS) then
         print *, 'Error: Invalid number of zones'
         stop
      endif

      if ((bx*by*bz) .gt. MAXBLKS) then
         print *, 'Error: Invalid number of blocks'
         stop
      endif

c-----------------------------------------------------------------------
c     Print driver parameters
c-----------------------------------------------------------------------

      if (myid .eq. 0) then
         print *, 'Running with these driver parameters:'
         print *, '  (nx, ny, nz)    = (', nx, ',', ny, ',', nz, ')'
         print *, '  (Px, Py, Pz)    = (',  Px, ',',  Py, ',',  Pz, ')'
         print *, '  (bx, by, bz)    = (', bx, ',', by, ',', bz, ')'
         print *, '  (cx, cy, cz)    = (', cx, ',', cy, ',', cz, ')'
         print *, '  (n_pre, n_post) = (', n_pre, ',', n_post, ')'
         print *, '  dim             = ', dim
         print *, '  solver ID       = ', solver_id
      endif

c-----------------------------------------------------------------------
c     Set up dxyz for PFMG solver
c-----------------------------------------------------------------------

      dxyz(1) = dsqrt(1.d0 / cx)
      dxyz(2) = dsqrt(1.d0 / cy)
      dxyz(3) = dsqrt(1.d0 / cz)

c-----------------------------------------------------------------------
c     Compute some grid and processor information
c-----------------------------------------------------------------------

      if (dim .eq. 1) then
         volume  = nx
         nblocks = bx

c        compute p from Px and myid
         p = mod(myid,Px)
      elseif (dim .eq. 2) then
         volume  = nx*ny
         nblocks = bx*by

c        compute p,q from Px, Py and myid
         p = mod(myid,Px)
         q = mod(((myid - p)/Px),Py)
      elseif (dim .eq. 3) then
         volume  = nx*ny*nz
         nblocks = bx*by*bz

c        compute p,q,r from Px,Py,Pz and myid
         p = mod(myid,Px)
         q = mod((( myid - p)/Px),Py)
         r = (myid - (p + Px*q))/(Px*Py)
      endif

c----------------------------------------------------------------------
c    Compute ilower and iupper from (p,q,r), (bx,by,bz), and (nx,ny,nz)
c    and set up the grid structure.
c----------------------------------------------------------------------

      ib = 1
      if (dim .eq. 1) then
         do ix=0,bx-1
            ilower(1,ib) = istart(1) + nx*(bx*p+ix)
            iupper(1,ib) = istart(1) + nx*(bx*p+ix+1)-1
            ib = ib + 1
         enddo
      elseif (dim .eq. 2) then
         do iy=0,by-1
            do ix=0,bx-1
               ilower(1,ib) = istart(1) + nx*(bx*p+ix)
               iupper(1,ib) = istart(1) + nx*(bx*p+ix+1)-1
               ilower(2,ib) = istart(2) + ny*(by*q+iy)
               iupper(2,ib) = istart(2) + ny*(by*q+iy+1)-1
               ib = ib + 1
            enddo
         enddo
      elseif (dim .eq. 3) then
         do iz=0,bz-1
            do iy=0,by-1
               do ix=0,bx-1
                  ilower(1,ib) = istart(1) + nx*(bx*p+ix)
                  iupper(1,ib) = istart(1) + nx*(bx*p+ix+1)-1
                  ilower(2,ib) = istart(2) + ny*(by*q+iy)
                  iupper(2,ib) = istart(2) + ny*(by*q+iy+1)-1
                  ilower(3,ib) = istart(3) + nz*(bz*r+iz)
                  iupper(3,ib) = istart(3) + nz*(bz*r+iz+1)-1
                  ib = ib + 1
               enddo
            enddo
         enddo
      endif

      call bHYPRE_StructGrid_Create_f( bHYPRE_mpicomm, dim, grid,
     1                                 except )
      do ib=1,nblocks
         call bHYPRE_StructGrid_SetExtents_f( grid, ilower(1,ib),
     1        iupper(1,ib), dim, ierr, except )
      enddo

      periodic(1) = 0
      periodic(2) = 0
      periodic(3) = 0
      call bHYPRE_StructGrid_SetPeriodic_f( grid, periodic, dim,
     1     ierr, except )
      call bHYPRE_StructGrid_Assemble_f( grid, ierr, except )

c----------------------------------------------------------------------
c     Compute the offsets and set up the stencil structure.
c----------------------------------------------------------------------

      if (dim .eq. 1) then
         offsets(1,1) = -1
         offsets(1,2) =  0
      elseif (dim .eq. 2) then
         offsets(1,1) = -1
         offsets(2,1) =  0
         offsets(1,2) =  0
         offsets(2,2) = -1
         offsets(1,3) =  0
         offsets(2,3) =  0
      elseif (dim .eq. 3) then
         offsets(1,1) = -1
         offsets(2,1) =  0
         offsets(3,1) =  0
         offsets(1,2) =  0
         offsets(2,2) = -1
         offsets(3,2) =  0
         offsets(1,3) =  0
         offsets(2,3) =  0
         offsets(3,3) = -1
         offsets(1,4) =  0
         offsets(2,4) =  0
         offsets(3,4) =  0
      endif

      call bHYPRE_StructStencil_Create_f( dim, dim+1, stencil, except )

      do s=1,dim+1
         call bHYPRE_StructStencil_SetElement_f( stencil, (s-1),
     1        offsets(1,s), dim, ierr, except )
      enddo

c-----------------------------------------------------------------------
c     Set up the matrix structure
c-----------------------------------------------------------------------

      do i=1,dim
         A_num_ghost(2*i - 1) = 1
         A_num_ghost(2*i) = 1
      enddo

      symmetric = 1
      itemp2 = 2*dim
      call bHYPRE_StructMatrix_Create_f( bHYPRE_mpicomm, grid, stencil,
     1     A, except )
      call bHYPRE_StructMatrix_SetSymmetric_f( A, symmetric,
     2     ierr, except )
      call bHYPRE_StructMatrix_SetNumGhost_f( A, A_num_ghost, 2*dim,
     1     ierr, except )

      call bHYPRE_StructMatrix_Initialize_f( A, ierr, except )

c-----------------------------------------------------------------------
c     Set the coefficients for the grid
c-----------------------------------------------------------------------

      do s=1,(dim + 1)
         stencil_indices(s) = s - 1
      enddo

      do i=1,(dim + 1)*volume,(dim + 1)
         if (dim .eq. 1) then
            values(i  ) = -cx
            values(i+1) = 2.0*(cx)
         elseif (dim .eq. 2) then
            values(i  ) = -cx
            values(i+1) = -cy
            values(i+2) = 2.0*(cx+cy)
         elseif (dim .eq. 3) then
            values(i  ) = -cx
            values(i+1) = -cy
            values(i+2) = -cz
            values(i+3) = 2.0*(cx+cy+cz)
         endif
      enddo

      itemp2 = dim+1
      itemp3 = (dim+1)*volume
      do ib=1,nblocks
         call bHYPRE_StructMatrix_SetBoxValues_f( A,
     1        ilower(1,ib), iupper(1,ib), dim, dim+1,
     2        stencil_indices,  values, (dim+1)*volume, ierr, except )
      enddo

c-----------------------------------------------------------------------
c     Zero out stencils reaching to real boundary, then assemble.
c-----------------------------------------------------------------------

      call SetStencilBndry( A, ilower, iupper,
     1     istart, iend, nblocks, dim, periodic, ierr )

      call bHYPRE_StructMatrix_Assemble_f( A, ierr, except )

c-----------------------------------------------------------------------
c     Set up the rhs and initial guess
c-----------------------------------------------------------------------

      call bHYPRE_StructVector_Create_f( bHYPRE_mpicomm, grid,
     1     b, except )
      call bHYPRE_StructVector_Initialize_f( b, ierr, except )
      do i=1,volume
         values(i) = 1.0
      enddo
      do ib=1,nblocks
         call bHYPRE_StructVector_SetBoxValues_f( b,
     1        ilower(1,ib), iupper(1,ib), dim, values, volume,
     2        ierr, except )
      enddo
      call bHYPRE_StructVector_Assemble_f( b, ierr, except )
      call bHYPRE_Vector__cast_f( b, b_V, except )

      call bHYPRE_StructVector_Create_f( bHYPRE_mpicomm, grid,
     1     x, except )
      call bHYPRE_StructVector_Initialize_f( x, ierr, except )
      do i=1,volume
         values(i) = 0.0
      enddo
      do ib=1,nblocks
         call bHYPRE_StructVector_SetBoxValues_f( x,
     1        ilower(1,ib), iupper(1,ib), dim, values, volume,
     2        ierr, except )
      enddo
      call bHYPRE_StructVector_Assemble_f( x, ierr, except )
      call bHYPRE_Vector__cast_f( x, x_V, except )

c-----------------------------------------------------------------------
c     Solve the linear system
c-----------------------------------------------------------------------

c     General solver parameters
      maxiter = 50
      dscgmaxiter = 100
      pcgmaxiter = 50
      tol = 0.000001
      convtol = 0.9

      if (solver_id .eq. 0) then
c        Solve the system using SMG

         call bHYPRE_StructSMG_Create_f( bHYPRE_mpicomm, A, solver_SMG,
     1        except )

         call bHYPRE_StructSMG_SetIntParameter_f( solver_SMG,
     1        "MemoryUse", 0, ierr, except )
         call bHYPRE_StructSMG_SetIntParameter_f( solver_SMG,
     1        "MaxIter", 50, ierr, except )
         call bHYPRE_StructSMG_SetDoubleParameter_f( solver_SMG,
     1        "Tol", tol, ierr, except )
         call bHYPRE_StructSMG_SetIntParameter_f( solver_SMG,
     1        "RelChange", 0, ierr, except )
         call bHYPRE_StructSMG_SetIntParameter_f( solver_SMG,
     1        "NumPrerelax", n_pre, ierr, except )
         call bHYPRE_StructSMG_SetIntParameter_f( solver_SMG,
     1        "NumPostrelax", n_post, ierr, except )
         call bHYPRE_StructSMG_SetIntParameter_f( solver_SMG,
     1        "PrintLevel", 1, ierr, except )
         call bHYPRE_StructSMG_SetIntParameter_f( solver_SMG,
     1        "Logging", 1, ierr, except )

         call bHYPRE_StructSMG_Setup_f( solver_SMG, b_V, x_V,
     1        ierr, except )

         call bHYPRE_StructSMG_Apply_f( solver_SMG, b_V, x_V,
     1        ierr, except )

         call bHYPRE_StructSMG_GetIntValue_f( solver_SMG,
     1        "NumIterations", num_iterations, ierr, except )
         call bHYPRE_StructSMG_GetDoubleValue_f( solver_SMG,
     1        "RelResidualNorm", final_res_norm, ierr, except )

      call bHYPRE_StructSMG_deleteRef_f( solver_SMG, except )

      endif

c-----------------------------------------------------------------------
c     Print the solution and other info
c-----------------------------------------------------------------------

      if (myid .eq. 0) then
         print *, 'Iterations = ', num_iterations
         print *, 'Final Relative Residual Norm = ', final_res_norm
      endif

c-----------------------------------------------------------------------
c     Finalize things
c-----------------------------------------------------------------------

      call bHYPRE_Vector_deleteRef_f( b_V, except )
      call bHYPRE_Vector_deleteRef_f( x_V, except )
      call bHYPRE_StructVector_deleteRef_f( b, except )
      call bHYPRE_StructVector_deleteRef_f( x, except )
      call bHYPRE_StructMatrix_deleteRef_f( A, except )
      call bHYPRE_StructStencil_deleteRef_f( stencil, except )
      call bHYPRE_StructGrid_deleteRef_f( grid, except )
      call bHYPRE_MPICommunicator_deleteRef_f( bHYPRE_mpicomm, except )

c     Finalize MPI

      call MPI_FINALIZE(ierr)

      stop
      end

c-----------------------------------------------------------------------
c this function sets to zero the stencil entries that are on the boundary
c-----------------------------------------------------------------------

      subroutine SetStencilBndry( A_b, ilower, iupper,
     1     istart, iend, nblocks, dim, periodic, ierr )
      parameter (MAXZONS=4194304)
      parameter (MAXBLKS=32)
      integer*8 A_b
      integer ilower(3,MAXBLKS)
      integer iupper(3,MAXBLKS)
      integer istart(3)
      integer iend(3)
      integer dim
      integer nblocks
      integer periodic(3)
      integer ierr

      integer i,j,d,ib
      integer vol
      integer stencil_indices
      double precision values(MAXZONS)
      integer*8  except

      ierr = 0

      do d = 1, dim
         do ib = 1, nblocks
            vol = ( iupper(1,ib)-ilower(1,ib)+1 ) *
     1           ( iupper(2,ib)-ilower(2,ib)+1 ) *
     2           ( iupper(3,ib)-ilower(3,ib)+1 )
            do i = 1, vol
               values(i) = 0.0;
            enddo
            if( ilower(d,ib) .eq. istart(d) ) then
               if( periodic(d) .eq. 0 ) then
                  j = iupper(d,ib)
                  iupper(d,ib) = istart(d)
                  stencil_indices = d - 1

                  call bHYPRE_StructMatrix_SetBoxValues_f( A_b,
     1                 ilower(1,ib), iupper(1,ib), dim, 1,
     2                 stencil_indices,  values, vol, ierr,
     3                 except )
                  iupper(d,ib) = j
               endif
            endif

            if( iupper(d,ib) .eq. iend(d) ) then
               if( periodic(d) .eq. 0 ) then
                  j = ilower(d,ib)
                  ilower(d,ib) = iend(d)
                  stencil_indices = dim + d
                  call bHYPRE_StructMatrix_SetBoxValues_f( A_b,
     1                 ilower(1,ib), iupper(1,ib), dim, 1,
     2                 stencil_indices, values, vol, ierr, except)
                  ilower(d,ib) = j
               endif
            endif
         enddo
      enddo

      return
      end


module merge_mod_types
    use galapagos
    type(thefit),allocatable :: work(:)
    type(thefit), pointer:: a_pntr(:)
end module merge_mod_types

module sort_mod
!defining the interfaces
  interface operator (.lt.)  ! overloads standard .lt.
    module procedure theless ! the function that does it
  end interface

  interface operator (.gt.)   ! overloads standard .gt.
    module procedure thegreat ! the function that does it
  end interface

  interface operator (.ge.)  ! overloads standard .ge.
    module procedure thetest ! the function that does it
  end interface

  interface operator (.converged.)  ! new operator
    module procedure index_test     ! the function that does it
  end interface

contains

  function theless(a,b) ! overloads < for the type (thefit)
    use galapagos
    implicit none
    type(thefit), intent (in) :: a,b
    logical theless
    if(a%val < b%val)then ! this is where we do the test
        theless=.true.
    else
        theless=.false.
    endif
    return
  end function theless

  function thegreat(a,b) ! overloads > for the type (thefit)
    use galapagos
    implicit none
    type(thefit), intent (in) :: a,b
    logical thegreat
    if(a%val > b%val)then
        thegreat=.true.
    else
        thegreat=.false.
    endif
    return
  end function thegreat

function thetest(a,b)   ! overloads >= for the type (thefit)
    use galapagos
    implicit none
    type(thefit), intent (in) :: a,b
    logical thetest
    if(a%val >= b%val)then
        thetest=.true.
    else
        thetest=.false.
    endif
    return
end function thetest

function index_test(a,b) ! defines a new operation for the type (thefit)
    use galapagos
    implicit none
    type(thefit), intent (in) :: a,b
    logical index_test
    if(a%index > b%index)then ! check the index value for a difference
        index_test=.true.
    else
        index_test=.false.
    endif
    return
end function index_test

subroutine Sort(ain, n)
    use Merge_mod_types
    implicit none
    integer n
    type(thefit), target:: ain(n)
    allocate(work(n))
    nullify(a_pntr)
    a_pntr=>ain
    call RecMergeSort(1,n)
    deallocate(work)
    return
end subroutine Sort

! recursive merge sort taken from pascal routine in
! moret & shapiro
! algorithms from p to np, volume 1, design and efficiency
! benjamin/cummings 1991

recursive subroutine RecMergeSort(left, right)
    use Merge_mod_types
    implicit none
    integer,intent(in):: left,right
    integer  middle
    if (left < right) then
        middle = (left + right) / 2
        call RecMergeSort(left,middle)
        call RecMergeSort(middle+1,right)
        call Merge(left,middle-left+1,right-middle)
    endif
    return
end subroutine RecMergeSort

subroutine Merge(s, n, m)
    use Merge_mod_types
    implicit none
    integer s,n,m
    integer i,  j, k, t, u
    k = 1
    t = s + n
    u = t + m
    i = s
    j = t
    if ((i < t) .and. (j < u))then
        do while ((i < t) .and. (j < u))
            if (a_pntr(i) .ge.  a_pntr(j))then
                work(k) = a_pntr(i)
                i = i + 1
                k = k + 1
            else
                work(k) = a_pntr(j)
                j = j + 1
                k = k + 1
            endif
         enddo
    endif
    if(i < t )then
        do while (i < t )
            work(k) = a_pntr(i)
            i = i + 1
            k = k + 1
        enddo
    endif
    if(j < u)then
        do while (j < u )
            work(k) = a_pntr(j)
            j = j + 1
            k = k + 1
        enddo
    endif
    i = s
! the next line is not in moret & shapiro's book
! but should be
    k=k-1
    do j = 1 , k
        a_pntr(i) = work(j)
        i = i + 1
    enddo
    return
end subroutine Merge

end module sort_mod


module stdlib_modules
    use :: stdlib_array
    use :: stdlib_ascii
    use :: stdlib_bitsets
    use :: stdlib_error
    use :: stdlib_hash_32bit
    use :: stdlib_hash_64bit
    use :: stdlib_io
    use :: stdlib_io_npy
    use :: stdlib_kinds
    use :: stdlib_linalg
    use :: stdlib_logger
    use :: stdlib_math
    use :: stdlib_optval
    use :: stdlib_quadrature
    use :: stdlib_random
    use :: stdlib_selection
    use :: stdlib_sorting
    use :: stdlib_specialfunctions
    use :: stdlib_stats
    use :: stdlib_stats_distribution_exponential
    use :: stdlib_stats_distribution_normal
    use :: stdlib_stats_distribution_uniform
    use :: stdlib_string_type
    use :: stdlib_stringlist_type
    use :: stdlib_strings
    use :: stdlib_system
    use :: stdlib_version
end module stdlib_modules