module module_neural_net
    use netcdf
    implicit none
    integer, parameter, public :: r8 = selected_real_kind(12)
    type Dense
        integer :: input_size
        integer :: output_size
        integer :: batch_size
        integer :: activation
        real(kind=8), allocatable :: weights(:, :)
        real(kind=8), allocatable :: bias(:)
        real(kind=8), allocatable :: input(:, :)
        real(kind=8), allocatable :: output(:, :)
    end type Dense

contains

    subroutine apply_dense(input, layer, output)
        ! Description: Pass a set of input data through a single dense layer and nonlinear activation function
        !
        ! Inputs:
        ! layer (input): a single Dense object
        ! input (input): a 2D array where the rows are different examples and
        !   the columns are different model inputs
        !
        ! Output:
        ! output: output of the dense layer as a 2D array with shape (number of inputs, number of neurons)
        real(kind=8), dimension(:, :), intent(in) :: input
        type(Dense), intent(in) :: layer
        real(kind=8), dimension(size(input, 1), layer%output_size), intent(out) :: output
        real(kind=8), dimension(size(input, 1), layer%output_size) :: dense_output
        integer :: i, j, num_examples
        real(kind=8) :: alpha, beta
        external :: dgemm
        !real(kind=8) :: time_start, time_end
        alpha = 1
        beta = 1
        dense_output = 0
        output = 0
        num_examples = size(input, 1)
        !call cpu_time(time_start)
        !print*, "Input", size(input, 1), size(input, 2), input
        call dgemm('n', 'n', num_examples, layer%output_size, layer%input_size, &
            alpha, input, num_examples, layer%weights, layer%input_size, beta, dense_output, num_examples)
        !call cpu_time(time_end)
        !print *, num_examples, layer%output_size, layer%input_size
        !print *, "After dgemm ", dense_output(1, 1), time_end - time_start
        !call cpu_time(time_start)
        !dense_output = matmul(input, layer%weights)
        !call cpu_time(time_end)
        !print *, "After matmul", dense_output(1, 1), time_end - time_start
        do i=1, num_examples
            do j=1, layer%output_size
                dense_output(i, j) = dense_output(i, j) + layer%bias(j)
            end do
        end do
        !print*, "Dense", size(dense_output, 1), size(dense_output, 2), dense_output
        call apply_activation(dense_output, layer%activation, output)
        !print*, "Activated", size(output, 1), size(output, 2), output
        return
    end subroutine apply_dense

    subroutine apply_activation(input, activation_type, output)
        ! Description: Apply a nonlinear activation function to a given array of input values.
        !
        ! Inputs:
        ! input: A 2D array
        ! activation_type: string describing which activation is being applied. If the activation
        !       type does not match any of the available options, the linear activation is applied.
        !       Currently supported activations are:
        !           relu
        !           elu
        !           selu
        !           sigmoid
        !           tanh
        !           softmax
        !           linear
        ! Output:
        ! output: Array of the same dimensions as input with the nonlinear activation applied.
        real(kind=8), dimension(:, :), intent(in) :: input
        integer, intent(in) :: activation_type
        real(kind=8), dimension(size(input, 1), size(input, 2)), intent(out) :: output

        real(kind=8), dimension(size(input, 1)) :: softmax_sum
        real(kind=8), parameter :: selu_alpha = 1.6732
        real(kind=8), parameter :: selu_lambda = 1.0507
        real(kind=8), parameter :: zero = 0.0
        integer :: i, j
        select case (activation_type)
            case (0)
                output = input
            case (1)
         !      print*, "relu"
                !where(input < 0)
                !    output = 0
                !elsewhere
                !    output = input
                !endwhere
                do i=1,size(input, 1)
                    do j=1, size(input,2)
                        output(i, j) = dmax1(input(i, j), zero)
                    end do
                end do
            case (2)
            !    print*, "sigmoid"
                output = 1.0 / (1.0 + exp(-input))
            case (3)
          !      print*, "elu"
                do i=1,size(input, 1)
                    do j=1, size(input,2)
                        output(i, j) = dmax1(input(i, j), exp(input(i, j))-1.0_r8)
                    end do
                end do
            case (4)
           !     print*, "selu"
                do i=1,size(input, 1)
                    do j=1, size(input,2)
                        output(i, j) = selu_lambda * ( dmax1(input(i, j),zero) + dmin1(selu_alpha*(exp(input(i, j))-1.0),zero) )
                    end do
                end do
            case (5)
             !   print*, "tanh"
                output = tanh(input)
            case (6)
             !   print*, "softmax"
                softmax_sum = sum(exp(input), dim=2)
                do i=1, size(input, 1)
                    do j=1, size(input, 2)
                        output(i, j) = exp(input(i, j)) / softmax_sum(i)
                    end do
                end do
            case default
             !   print*, "default linear"
                output = input
        end select
        return
    end subroutine apply_activation

    subroutine init_neural_net(filename, batch_size, neural_net_model)
        ! init_neuralnet
        ! Description: Loads dense neural network weights from a netCDF file and builds an array of
        ! Dense types from the weights and activations.
        !
        ! Input:
        ! filename: Full path to the netCDF file
        ! batch_size: number of items in single batch. Used to set intermediate array sizes.
        !
        ! Output:
        ! neural_net_model (output): array of Dense layers composing a densely connected neural network
        !
        character(len=*), intent(in) :: filename
        integer, intent(in) :: batch_size
        type(Dense), allocatable, intent(out) :: neural_net_model(:)
        integer :: ncid, num_layers_id, num_layers
        integer :: layer_names_var_id, i, layer_in_dimid, layer_out_dimid
        integer :: layer_in_dim, layer_out_dim
        integer :: layer_weight_var_id
        integer :: layer_bias_var_id

        character (len=8), allocatable :: layer_names(:)
        character (len=10) :: num_layers_dim_name = "num_layers"
        character (len=11) :: layer_name_var = "layer_names"
        character (len=11) :: layer_in_dim_name
        character (len=12) :: layer_out_dim_name
        character (len=10) :: activation_name
        real (kind=8), allocatable :: temp_weights(:, :)
        ! Open netCDF file
        call check(nf90_open(filename, nf90_nowrite, ncid))
        ! Get the number of layers in the neural network
        call check(nf90_inq_dimid(ncid, num_layers_dim_name, num_layers_id))
        call check(nf90_inquire_dimension(ncid, num_layers_id, &
                                          num_layers_dim_name, num_layers))
        call check(nf90_inq_varid(ncid, layer_name_var, layer_names_var_id))
        allocate(layer_names(num_layers))
        call check(nf90_get_var(ncid, layer_names_var_id, layer_names))
        print *, "load neural network " // filename
        allocate(neural_net_model(1:num_layers))
        ! Loop through each layer and load the weights, bias term, and activation function
        do i=1, num_layers
            layer_in_dim_name = trim(layer_names(i)) // "_in"
            layer_out_dim_name = trim(layer_names(i)) // "_out"
            layer_in_dimid = -1
            ! Get layer input and output dimensions
            call check(nf90_inq_dimid(ncid, trim(layer_in_dim_name), layer_in_dimid))
            call check(nf90_inquire_dimension(ncid, layer_in_dimid, layer_in_dim_name, layer_in_dim))
            call check(nf90_inq_dimid(ncid, trim(layer_out_dim_name), layer_out_dimid))
            call check(nf90_inquire_dimension(ncid, layer_out_dimid, layer_out_dim_name, layer_out_dim))
            call check(nf90_inq_varid(ncid, trim(layer_names(i)) // "_weights", &
                                      layer_weight_var_id))
            call check(nf90_inq_varid(ncid, trim(layer_names(i)) // "_bias", &
                                      layer_bias_var_id))
            neural_net_model(i)%input_size = layer_in_dim
            neural_net_model(i)%output_size = layer_out_dim
            neural_net_model(i)%batch_size = batch_size
            ! Fortran loads 2D arrays in the opposite order from Python/C, so I
            ! first load the data into a temporary array and then apply the
            ! transpose operation to copy the weights into the Dense layer
            allocate(neural_net_model(i)%weights(layer_in_dim, layer_out_dim))
            allocate(temp_weights(layer_out_dim, layer_in_dim))

            call check(nf90_get_var(ncid, layer_weight_var_id, &
                                    temp_weights))
            neural_net_model(i)%weights = transpose(temp_weights)
            allocate(neural_net_model(i)%input(batch_size, layer_in_dim))
            allocate(neural_net_model(i)%output(batch_size, layer_out_dim))
            deallocate(temp_weights)
            ! Load the bias weights
            allocate(neural_net_model(i)%bias(layer_out_dim))
            call check(nf90_get_var(ncid, layer_bias_var_id, &
                                    neural_net_model(i)%bias))
            ! Get the name of the activation function, which is stored as an attribute of the weights variable
            call check(nf90_get_att(ncid, layer_weight_var_id, "activation", &
                                    activation_name))
            select case (trim(activation_name))
                case ("linear")
                    neural_net_model(i)%activation = 0
                case ("relu")
                    neural_net_model(i)%activation = 1
                case ("sigmoid")
                    neural_net_model(i)%activation = 2
                case ("elu")
                    neural_net_model(i)%activation = 3
                case ("selu")
                    neural_net_model(i)%activation = 4
                case ("tanh")
                    neural_net_model(i)%activation = 5
                case ("softmax")
                    neural_net_model(i)%activation = 6
                case default
                    neural_net_model(i)%activation = 7
            end select
        end do
        !print *, "finished loading neural network " // filename
        call check(nf90_close(ncid))

    end subroutine init_neural_net

    subroutine neural_net_predict(input, neural_net_model, prediction)
        ! neural_net_predict
        ! Description: generate prediction from neural network model for an arbitrary set of input values
        !
        ! Args:
        ! input (input): 2D array of input values. Each row is a separate instance and each column is a model input.
        ! neural_net_model (input): Array of type(Dense) objects
        ! prediction (output): The prediction of the neural network as a 2D array of dimension (examples, outputs)
        real(kind=8), intent(in) :: input(:, :)
        type(Dense), intent(inout) :: neural_net_model(:)
        real(kind=8), intent(out) :: prediction(size(input, 1), neural_net_model(size(neural_net_model))%output_size)
        integer :: bi, i
        integer :: batch_size
        integer :: input_size
        integer :: batch_index_size
        integer, allocatable :: batch_indices(:)
        input_size = size(input, 1)
        batch_size = neural_net_model(1)%batch_size
        batch_index_size = input_size / batch_size
        allocate(batch_indices(batch_index_size))
        i = 1
        do bi=batch_size, input_size, batch_size
            batch_indices(i) = bi
            i = i + 1
        end do
        batch_indices(batch_index_size) = input_size
        do bi=1, batch_index_size
            neural_net_model(1)%input = input(batch_indices(bi)-batch_size+1:batch_indices(bi), :)
            do i=1, size(neural_net_model) - 1
                call apply_dense(neural_net_model(i)%input, neural_net_model(i), neural_net_model(i)%output)
                neural_net_model(i + 1)%input = neural_net_model(i)%output
            end do
                call apply_dense(neural_net_model(i)%input, neural_net_model(i), neural_net_model(i)%output)
            prediction(batch_indices(bi)-batch_size + 1:batch_indices(bi), :) = neural_net_model(size(neural_net_model))%output
        !    print*,"Prediction", prediction(batch_indices(bi)-batch_size + 1:batch_indices(bi), :)
        end do
        deallocate(batch_indices)
    end subroutine neural_net_predict

    subroutine standard_scaler_transform(input_data, scale_values, transformed_data)
        ! Perform z-score normalization of input_data table. Equivalent to scikit-learn StandardScaler.
        !
        ! Inputs:
        !   input_data: 2D array where rows are examples and columns are variables
        !   scale_values: 2D array where rows are the input variables and columns are mean and standard deviation
        ! Output:
        !   transformed_data: 2D array with the same shape as input_data containing the transformed values.
        real(8), intent(in) :: input_data(:, :)
        real(8), intent(in) :: scale_values(:, :)
        real(8), intent(out) :: transformed_data(size(input_data, 1), size(input_data, 2))
        integer :: i
        if (size(input_data, 2) /= size(scale_values, 1)) then
            print *, "Size mismatch between input data and scale values", size(input_data, 2), size(scale_values, 1)
            stop 2
        end if
        do i=1, size(input_data, 2)
            transformed_data(:, i) = (input_data(:, i) - scale_values(i, 1)) / scale_values(i, 2)
        end do
    end subroutine standard_scaler_transform

    subroutine load_scale_values(filename, num_inputs, scale_values)
        character(len=*), intent(in) :: filename
        integer, intent(in) :: num_inputs
        real(8), intent(out) :: scale_values(num_inputs, 2)
        character(len=40) :: row_name
        integer :: isu, i
        isu = 2
        open(isu, file=filename, access="sequential", form="formatted")
        read(isu, "(A)")
        do i=1, num_inputs
            read(isu, *) row_name, scale_values(i, 1), scale_values(i, 2)
        end do
        close(isu)
    end subroutine load_scale_values

    subroutine standard_scaler_inverse_transform(input_data, scale_values, transformed_data)
        ! Perform inverse z-score normalization of input_data table. Equivalent to scikit-learn StandardScaler.
        !
        ! Inputs:
        !   input_data: 2D array where rows are examples and columns are variables
        !   scale_values: 2D array where rows are the input variables and columns are mean and standard deviation
        ! Output:
        !   transformed_data: 2D array with the same shape as input_data containing the transformed values.
        real(8), intent(in) :: input_data(:, :)
        real(8), intent(in) :: scale_values(:, :)
        real(8), intent(out) :: transformed_data(size(input_data, 1), size(input_data, 2))
        integer :: i
        if (size(input_data, 2) /= size(scale_values, 1)) then
            print *, "Size mismatch between input data and scale values", size(input_data, 2), size(scale_values, 1)
            stop 2
        end if
        do i=1, size(input_data, 2)
            transformed_data(:, i) = input_data(:, i) * scale_values(i, 2) + scale_values(i, 1)
        end do
    end subroutine standard_scaler_inverse_transform

    subroutine minmax_scaler_transform(input_data, scale_values, transformed_data)
        ! Perform min-max scaling of input_data table. Equivalent to scikit-learn MinMaxScaler.
        !
        ! Inputs:
        !   input_data: 2D array where rows are examples and columns are variables
        !   scale_values: 2D array where rows are the input variables and columns are min and max.
        ! Output:
        !   transformed_data: 2D array with the same shape as input_data containing the transformed values.
        real(8), intent(in) :: input_data(:, :)
        real(8), intent(in) :: scale_values(:, :)
        real(8), intent(out) :: transformed_data(size(input_data, 1), size(input_data, 2))
        integer :: i
        if (size(input_data, 2) /= size(scale_values, 1)) then
            print *, "Size mismatch between input data and scale values", size(input_data, 2), size(scale_values, 1)
            stop 2
        end if
        do i=1, size(input_data, 2)
            transformed_data(:, i) = (input_data(:, i) - scale_values(i, 1)) / (scale_values(i, 2) - scale_values(i ,1))
        end do
    end subroutine minmax_scaler_transform

    subroutine minmax_scaler_inverse_transform(input_data, scale_values, transformed_data)
        ! Perform inverse min-max scaling of input_data table. Equivalent to scikit-learn MinMaxScaler.
        !
        ! Inputs:
        !   input_data: 2D array where rows are examples and columns are variables
        !   scale_values: 2D array where rows are the input variables and columns are min and max.
        ! Output:
        !   transformed_data: 2D array with the same shape as input_data containing the transformed values.
        real(8), intent(in) :: input_data(:, :)
        real(8), intent(in) :: scale_values(:, :)
        real(8), intent(out) :: transformed_data(size(input_data, 1), size(input_data, 2))
        integer :: i
        if (size(input_data, 2) /= size(scale_values, 1)) then
            print *, "Size mismatch between input data and scale values", size(input_data, 2), size(scale_values, 1)
            stop 2
        end if
        do i=1, size(input_data, 2)
            transformed_data(:, i) = input_data(:, i) * (scale_values(i, 2) - scale_values(i ,1)) + scale_values(i, 1)
        end do
    end subroutine minmax_scaler_inverse_transform

    subroutine check(status)
        ! Check for netCDF errors
        integer, intent ( in) :: status
        if(status /= nf90_noerr) then
          print *, trim(nf90_strerror(status))
          stop 2
        end if
    end subroutine check

    subroutine print_2d_array(input_array)
        ! Print 2D array in pretty format
        real(kind=8), intent(in) :: input_array(:, :)
        integer :: i, j
        do i=1, size(input_array, 1)
            do j=1, size(input_array, 2)
                write(*, fmt="(1x,a,f6.3)", advance="no") "", input_array(i, j)
            end do
            write(*, *)
        end do
    end subroutine print_2d_array
end module module_neural_net


! Copyright (c) 2020, Lehrstuhl fuer Angewandte Mechanik, Technische
! Universitaet Muenchen.
!
! Distributed under BSD-3-Clause License. See LICENSE-File for more information
!
! Author: Christian Meyer
!
module quadrature
    use, intrinsic:: iso_fortran_env, only: dp=>real64
    implicit none

    private
    public quadrature_1d, quadrature_2d, quadrature_3d

    contains

        subroutine quadrature_1d(f_1d, out, evaluationpoints, weights, out_no_of_rows, out_no_of_cols, no_of_gps)
            integer, intent(in) :: out_no_of_rows
            integer, intent(in) :: out_no_of_cols
            integer, intent(in) :: no_of_gps
            interface
                subroutine integrand_1d(xi_, out_)
                    import :: out_no_of_rows, out_no_of_cols, dp
                    real(dp), intent(in) :: xi_
                    real(dp), intent(out) :: out_(out_no_of_rows, out_no_of_cols)
                end subroutine integrand_1d
            end interface
            procedure(integrand_1d) :: f_1d
            real(dp), intent(out) :: out(out_no_of_rows, out_no_of_cols)
            real(dp), intent(in) :: evaluationpoints(1,no_of_gps)
            real(dp), intent(in) :: weights(no_of_gps)

            real(dp) :: out_local(out_no_of_rows, out_no_of_cols)
            integer :: g

            out(:,:) = 0.0_dp
            do g=1,no_of_gps
                call f_1d(evaluationpoints(1,g),out_local)
                out = out + weights(g) * out_local
            end do

        end subroutine quadrature_1d

        subroutine quadrature_2d(f_2d, out, evaluationpoints, weights, out_no_of_rows, out_no_of_cols, no_of_gps)
            integer, intent(in) :: out_no_of_rows
            integer, intent(in) :: out_no_of_cols
            integer, intent(in) :: no_of_gps
            interface
                subroutine integrand_2d(xi_, eta_, out_)
                    import :: out_no_of_rows, out_no_of_cols, dp
                    real(dp), intent(in) :: xi_
                    real(dp), intent(in) :: eta_
                    real(dp), intent(out) :: out_(out_no_of_rows, out_no_of_cols)
                end subroutine integrand_2d
            end interface
            procedure(integrand_2d) :: f_2d
            real(dp), intent(inout) :: out(out_no_of_rows, out_no_of_cols)
            real(dp), intent(in) :: evaluationpoints(2,no_of_gps)
            real(dp), intent(in) :: weights(no_of_gps)

            real(dp) :: out_local(out_no_of_rows, out_no_of_cols)
            integer :: g

            out(:,:) = 0.0_dp
            do g=1,no_of_gps
                call f_2d(evaluationpoints(1,g), evaluationpoints(2,g), out_local)
                out = out + weights(g) * out_local
            end do

        end subroutine quadrature_2d

        subroutine quadrature_3d(f_3d, out, evaluationpoints, weights, out_no_of_rows, out_no_of_cols, no_of_gps)
            integer, intent(in) :: out_no_of_rows
            integer, intent(in) :: out_no_of_cols
            integer, intent(in) :: no_of_gps
            interface
                subroutine integrand_3d(xi_, eta_, zeta_, out_)
                    import :: out_no_of_rows, out_no_of_cols, dp
                    real(dp), intent(in) :: xi_
                    real(dp), intent(in) :: eta_
                    real(dp), intent(in) :: zeta_
                    real(dp), intent(out) :: out_(out_no_of_rows, out_no_of_cols)
                end subroutine integrand_3d
            end interface
            procedure(integrand_3d) :: f_3d
            real(dp), intent(inout) :: out(out_no_of_rows, out_no_of_cols)
            real(dp), intent(in) :: evaluationpoints(3,no_of_gps)
            real(dp), intent(in) :: weights(no_of_gps)

            real(dp) :: out_local(out_no_of_rows, out_no_of_cols)
            integer :: g

            out(:,:) = 0.0_dp
            do g=1,no_of_gps
                call f_3d(evaluationpoints(1,g), evaluationpoints(1,g), evaluationpoints(1,g), &
                        out_local)
                out = out + weights(g) * out_local
            end do

        end subroutine quadrature_3d

end module quadrature


!##############################################################################
!# Tutorial 012d: Create a mesh hierarchy
!##############################################################################

module tutorial012d

  ! Include basic Feat-2 modules
  use fsystem
  use genoutput

  use boundary
  use triangulation
  use ucd

  use meshhierarchy

  implicit none
  private

  public :: start_tutorial012d

contains

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

  subroutine start_tutorial012d

    ! Declare some variables.
    type(t_boundary) :: rboundary
    type(t_triangulation) :: rtriangulation
    type(t_ucdExport) :: rexport
    character(LEN=SYS_STRLEN) :: spredir,spostdir
    integer :: i

    type(t_meshHierarchy) :: rmeshHierarchy

    ! Print a message
    call output_lbrk()
    call output_separator (OU_SEP_STAR)
    call output_line ("This is FEAT-2. Tutorial 012d")
    call output_separator (OU_SEP_MINUS)

    ! =================================
    ! Read the underlying domain
    ! and the mesh
    ! =================================

    if (sys_getenv_string("PREDIR",spredir)) then
      call boundary_read_prm(rboundary, trim(spredir)//"/QUAD.prm")
    else
      call boundary_read_prm(rboundary, "pre/QUAD.prm")
    end if

    ! The mesh must always be in "standard" format to work with it.
    ! First read, then convert to standard.
    if (sys_getenv_string("PREDIR",spredir)) then
      call tria_readTriFile2D (rtriangulation, trim(spredir)//"/QUAD.tri", rboundary)
    else
      call tria_readTriFile2D (rtriangulation, "pre/QUAD.tri", rboundary)
    end if
    call tria_initStandardMeshFromRaw (rtriangulation,rboundary)

    ! =================================
    ! Create a hierarchy of 5 meshes with
    ! rtriangulation as coarse mesh.
    ! =================================

    ! Create a hierarchy with 5 levels,
    ! initialise the coarse mesh with rtriangulation
    call mshh_initHierarchy (rmeshHierarchy,rtriangulation,0,5,rboundary)

    ! Refine the coarse mesh 5x to get the hierarchy.
    call mshh_refineHierarchy2lv (rmeshHierarchy,5,rboundary=rboundary)

    ! =================================
    ! Write the meshes
    ! =================================

    do i=1,rmeshHierarchy%nlevels
      if (sys_getenv_string("POSTDIR",spostdir)) then
        call output_line ("Writing file '"//trim(spostdir)//"/tutorial012d_level"//trim(sys_siL(i,10))//".vtk'.")
      else
        call output_line ("Writing file './post/tutorial012d_level"//trim(sys_siL(i,10))//".vtk'.")
      end if

      ! Open / write / close
      if (sys_getenv_string("POSTDIR",spostdir)) then
        call ucd_startVTK (rexport,UCD_FLAG_STANDARD,rmeshHierarchy%p_Rtriangulations(i),&
            trim(spostdir)//"/tutorial012d_level"//trim(sys_siL(i,10))//".vtk")
      else
        call ucd_startVTK (rexport,UCD_FLAG_STANDARD,rmeshHierarchy%p_Rtriangulations(i),&
            "post/tutorial012d_level"//trim(sys_siL(i,10))//".vtk")
      end if
      call ucd_write (rexport)
      call ucd_release (rexport)
    end do

    ! =================================
    ! Cleanup
    ! =================================

    ! Release the mesh hierarchy
    call mshh_releaseHierarchy (rmeshHierarchy)

    ! Release the triangulation
    call tria_done (rtriangulation)

    ! Release the boundary definition
    call boundary_release(rboundary)
  end subroutine

end module


      subroutine init_data (U, lo, hi, Ncomp, ng,  &
                            dx, prob_lo, prob_hi)

      implicit none

      integer          :: lo(3), hi(3), Ncomp, ng
      double precision :: U(lo(1)-ng:hi(1)+ng, lo(2)-ng:hi(2)+ng, lo(3)-ng:hi(3)+ng, Ncomp)
      double precision :: dx(3)
      double precision :: prob_lo(3)
      double precision :: prob_hi(3)

      integer          :: i,j,k
      double precision :: x,y,z,r2

      do k = lo(3), hi(3)
         z = prob_lo(3) + (dble(k)+0.5d0) * dx(3)
         do j = lo(2), hi(2)
            y = prob_lo(2) + (dble(j)+0.5d0) * dx(2)
            do i = lo(1), hi(1)
               x = prob_lo(1) + (dble(i)+0.5d0) * dx(1)
               r2 = (x*x + y*y + z*z) / 0.01

               U(i,j,k,1) = 0.d0
               U(i,j,k,2) = exp(-r2)

            end do
         end do
      end do

      end subroutine init_data


module fqs_rotations

    use fqs_types,       only: wp
    use fqs_vector,      only: vect_t
    use fqs_quaternion,  only: quat_t
    use fqs_euler_angle, only: euler_t
    use fqs_axis_angle,  only: axis_angle_t
    use fqs_wing_frame,  only: wing_frame_t
    use fqs_conversions, only: quat_from_vect
    use fqs_conversions, only: vect_from_quat
    use fqs_conversions, only: quat_from_euler
    use fqs_conversions, only: euler_from_quat
    use fqs_conversions, only: quat_from_axis_angle
    use fqs_conversions, only: quat_from_euler

    implicit none

    private

    public :: rotate

    interface rotate
        procedure :: rotate_euler_by_axis_angle
        procedure :: rotate_vect_by_axis_angle
        procedure :: rotate_vect_by_euler
        procedure :: rotate_wing_frame_by_euler
        procedure :: rotate_wing_frame_by_axis_angle
    end interface rotate

contains

    elemental function rotate_euler_by_axis_angle(euler, axis_angle) result(euler_new)
        ! Rotates euler angles using and axis angle rotatation
        type(euler_t),      intent(in) :: euler
        type(axis_angle_t), intent(in) :: axis_angle
        type(euler_t)                  :: euler_new

        ! Local variables
        type(quat_t)               :: q_euler
        type(quat_t)               :: q_euler_new
        type(quat_t)               :: q_rot
        type(quat_t)               :: q_rot_inv

        q_euler = quat_from_euler(euler)
        q_rot = quat_from_axis_angle(axis_angle)
        q_rot_inv = q_rot%inv()
        q_euler_new = q_rot * (q_euler * q_rot_inv)
        euler_new = euler_from_quat(q_euler_new)
    end function rotate_euler_by_axis_angle

    elemental function rotate_vect_by_axis_angle(v, axis_angle) result(w)
        ! Rotates a vector using an axis and angle rotation
        type(vect_t),       intent(in) :: v
        type(axis_angle_t), intent(in) :: axis_angle
        type(vect_t)                   :: w

        ! Local variables
        type(quat_t)               :: q_v
        type(quat_t)               :: q_w
        type(quat_t)               :: q_rot
        type(quat_t)               :: q_rot_inv

        q_v = quat_from_vect(v)
        q_rot = quat_from_axis_angle(axis_angle)
        q_rot_inv = q_rot%inv()
        q_w = q_rot * (q_v * q_rot_inv)
        w = vect_from_quat(q_w)
    end function rotate_vect_by_axis_angle

    elemental function rotate_vect_by_euler(v, euler) result(w)
        ! Rotates a vector using euler euler
        type(vect_t),  intent(in)  :: v
        type(euler_t), intent(in)  :: euler
        type(vect_t)               :: w

        ! Local variables
        type(quat_t)               :: q_v
        type(quat_t)               :: q_w
        type(quat_t)               :: q_rot
        type(quat_t)               :: q_rot_inv

        q_v = quat_from_vect(v)
        q_rot = quat_from_euler(euler)
        q_rot_inv = q_rot%inv()
        q_w = q_rot * (q_v * q_rot_inv)
        w = vect_from_quat(q_w)
    end function rotate_vect_by_euler

    elemental function rotate_wing_frame_by_euler(frame, euler) result(frame_rot)
        ! Rotates a wing referene frame using euler angle
        type(wing_frame_t), intent(in) :: frame
        type(euler_t),      intent(in) :: euler
        type(wing_frame_t)             :: frame_rot
        frame_rot % u_axis  = rotate_vect_by_euler(frame % u_axis,  euler)
        frame_rot % u_chord = rotate_vect_by_euler(frame % u_chord, euler)
        frame_rot % u_norm  = rotate_vect_by_euler(frame % u_norm,  euler)
    end function rotate_wing_frame_by_euler

    elemental function rotate_wing_frame_by_axis_angle(frame, axis_angle) result(frame_rot)
        ! Rotates a wing referene frame using an axis and angle rotation
        type(wing_frame_t), intent(in) :: frame
        type(axis_angle_t), intent(in) :: axis_angle
        type(wing_frame_t)             :: frame_rot
        frame_rot % u_axis  = rotate_vect_by_axis_angle(frame % u_axis,  axis_angle)
        frame_rot % u_chord = rotate_vect_by_axis_angle(frame % u_chord, axis_angle)
        frame_rot % u_norm  = rotate_vect_by_axis_angle(frame % u_norm,  axis_angle)
    end function rotate_wing_frame_by_axis_angle

end module fqs_rotations


module mgaunt
  DOUBLE PRECISION, allocatable :: YR(:,:)
  INTEGER N, MAXDIM
  PARAMETER (N=6, MAXDIM=81)
CONTAINS
  DOUBLE PRECISION FUNCTION GAUNT1(LP,L,LS,MP,M,MS)
    IMPLICIT NONE
    !  Arguments
    INTEGER, intent(in) :: L, LP, LS, M, MP, MS
    !..................................................................
    !   GAUNT computes the integral of
    !      CONJG(Y(LP,MP))*Y(L,M)*Y(LS,MS) for LP+L+LS .LE. 23
    !   using gaussian quadrature with N=12 as given by
    !      M. Abramowitz and I.A. Stegun,
    !      'Handbook of Mathematical Functions',
    !      NBS Applied Mathematics Series 55 (1968), pages 887 and 916
    !   written by Bruce Harmon based on suggestion by W. Rudge
    !   Iowa State Sept.1973
    !
    !   extended by M. Weinert and E. Wimmer
    !   Northwestern University March 1980
    !..................................................................
    DOUBLE PRECISION   ZERO
    PARAMETER          (ZERO = 0.0D+0)
    !        Local Scalars
    INTEGER            I, IL, ILP, ILS
    DOUBLE PRECISION   S
    DOUBLE PRECISION   W(N)
    !        Data statements
    DATA W /0.24914704581340D+0, 0.23349253653836D+0, 0.20316742672307D+0, 0.16007832854335D+0,0.10693932599532D+0, 0.04717533638651D+0/
    !
    IL = L*(L+1) + M + 1
    ILP = LP*(LP+1) + MP + 1
    ILS = LS*(LS+1) + MS + 1
    S = ZERO
    DO I = 1, N
       S = S + W(I)*YR(I,ILP)*YR(I,IL)*YR(I,ILS)
    ENDDO
    GAUNT1 = S
    RETURN
  END FUNCTION GAUNT1

  SUBROUTINE gaunt_init
    IMPLICIT NONE
    !..................................................................
    !   set YR needed in function GAUNT1
    !..................................................................
    DOUBLE PRECISION   ZERO, SNULL, ONE
    PARAMETER          (ZERO = 0.0D+0, SNULL = 1.0D-10, ONE = 1.0D+0)
    !        Locals
    INTEGER            I, IDWN, IX, K, L, L1, L2, LM, LM2, LOMAX, M
    INTEGER            M1
    DOUBLE PRECISION   C1L, C2L, CD, CSR, CTH, CYP, FACTOR, FPI
    DOUBLE PRECISION   RF, SGNM, STH, TCTH
    DOUBLE PRECISION   X(N), P(10,10)
    !        Intrinsic Functions
    INTRINSIC          ABS, SQRT
    !        Data statements
    DATA X /0.12523340851147D+0, 0.36783149899818D+0, 0.58731795428662D+0, 0.76990267419431D+0, 0.90411725637048D+0, 0.98156063424672D+0/
    !
    allocate( YR(N, MAXDIM) )
    YR(:,:)=0.0D0

    FPI = 16.0D+0*ATAN(1.0D+0)
    FACTOR = FPI**(1.0D+0/3.0D+0)
    LOMAX = 8
    !
    DO K = 1, N
       CTH = X(K)
       STH = SQRT(ONE-CTH*CTH)
       RF = ONE/SQRT(FPI)
       YR(K,1) = RF*FACTOR
       I = 1
       P(1,1) = ONE
       P(2,1) = CTH
       C2L = CTH
       TCTH = CTH + CTH
       L1 = 2
       L = 1
       DO
          M = 1
          I = I + L
          IDWN = I + 2
          M1 = 2
          L2 = L
          L = L1
          L1 = L + 1
          LM = L2
          LM2 = L
          CD = ONE
          C2L = C2L + TCTH
          SGNM = ONE
20        CONTINUE
          !
          !        recurse upward in L
          !
          P(L1,M) = (C2L*P(L,M)-LM*P(L2,M))/LM2
          C1L = (LM+1)*CTH
          P(L,M1) = ZERO
          !
          !        recurse upward in M
          !
          IF (ABS(STH) .GE. SNULL) P(L,M1) = (C1L*P(L,M)-LM2*P(L1,M))/STH
30        CONTINUE
          I = I + 1
          IDWN = IDWN - 1
          CSR = SQRT((2*L-ONE)/(FPI*CD))
          CYP = SGNM*CSR*P(L,M)
          YR(K,I) = CYP*FACTOR
          IX = I - (L*L - L + 1)
          IF (IDWN .NE. I) YR(K,IDWN) = FACTOR*CYP*(-1)**IX
          M = M1
          M1 = M + 1
          LM2 = LM2 - 1
          LM = LM + 1
          CD = CD*LM*LM2
          SGNM = -SGNM
          IF (M - L) 20, 30, 40
40        CONTINUE
          IF (L.GT.LOMAX) EXIT
       ENDDO
    ENDDO
    !
    RETURN
  END SUBROUTINE GAUNT_INIT

end module mgaunt


      LOGICAL FUNCTION TRNSEQ (SZ, ACTMAT,EXPMAT)

C  Test two square matrices to see if they represent the same homogeneous
C  transformation.  Each transformation has an infinite number of
C  representations, because the matrix is scaled by element (sz,sz).

      INTEGER   SZ, I,J
      REAL      ACTMAT(SZ,SZ), EXPMAT(SZ,SZ), ASCALE, BSCALE
      LOGICAL   APPEQ

      ASCALE = ACTMAT(SZ,SZ)
      BSCALE = EXPMAT(SZ,SZ)

      IF (ASCALE*BSCALE .EQ. 0.0) THEN
C at least one is zero
         IF (ASCALE .EQ. BSCALE) THEN
C both are zero - set to 1.0 - both matrices represent transformation to
C points at infinity
            ASCALE = 1.0
            BSCALE = 1.0
         ELSE
C one zero and one not -
            TRNSEQ = .FALSE.
            RETURN
         ENDIF
      ENDIF

      DO 100 I = 1,SZ
      DO 200 J = 1,SZ
         IF (.NOT. APPEQ(ACTMAT(I,J)/ASCALE,
     1                   EXPMAT(I,J)/BSCALE, 1E-7, 1E-4)) THEN
            TRNSEQ = .FALSE.
            RETURN
         ENDIF
200   CONTINUE
100   CONTINUE

      TRNSEQ = .TRUE.

      END


! Copyright (c) 2019 Etienne Descamps
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification,
! are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
!    this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation and/or
!    other materials provided with the distribution.
!
! 3. Neither the name of the copyright holder nor the names of its contributors may be
!    used to endorse or promote products derived from this software without specific prior
!    written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
! ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
! WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
! IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
! INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
! (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
! EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Module mlf_normal_inverse_gamma
  Use ieee_arithmetic
  Use iso_c_binding
  Use mlf_utils
  Use mlf_cfuns
  Use mlf_distribution
  IMPLICIT NONE
  PRIVATE

  Type, Public, Extends(mlf_distribution_multivariate) :: mlf_distribution_normalInverseGamma
    real(c_double) :: mu, lambda, alpha, beta
  Contains
    procedure :: getParameters => normalInverseGamma_getParameters
    procedure :: withParameters => normalInverseGamma_withParameters
    procedure :: computePDF => normalInverseGamma_computePDF
    procedure :: computeLogPDF => normalInverseGamma_computeLogPDF
    procedure :: fitWithData => normalInverseGamma_fitWithData
  End Type mlf_distribution_normalInverseGamma

  Type, Public, Extends(mlf_distribution_univariate) :: mlf_posterior_normalInverseGamma
    real(c_double) :: mu, lambda, alpha, beta
  Contains
    procedure :: getParameters => posterior_normalInverseGamma_getParameters
    procedure :: withParameters => posterior_normalInverseGamma_withParameters
    procedure :: fitWithData => posterior_normalInverseGamma_fitWithData
    procedure :: computePDF => posterior_normalInverseGamma_computePDF
    procedure :: computeLogPDF => posterior_normalInverseGamma_computeLogPDF
    procedure :: getStats => posterior_normalInverseGamma_getStats
  End Type mlf_posterior_normalInverseGamma
Contains
  Integer Function normalInverseGamma_getParameters(this, X) Result(info)
    class(mlf_distribution_normalInverseGamma), intent(in) :: this
    real(c_double), intent(out) :: X(:)
    info = 0
    X = [this%mu, this%lambda, this%alpha, this%beta]
  End Function normalInverseGamma_getParameters

  Integer Function normalInverseGamma_withParameters(this, X) Result(info)
    class(mlf_distribution_normalInverseGamma), intent(inout) :: this
    real(c_double), intent(in) :: X(:)
    info = 0
    this%mu = X(1); this%lambda = X(2); this%alpha = X(3); this%beta = X(4)
  End Function normalInverseGamma_withParameters

  Integer Function posterior_normalInverseGamma_getParameters(this, X) Result(info)
    class(mlf_posterior_normalInverseGamma), intent(in) :: this
    real(c_double), intent(out) :: X(:)
    info = 0
    X = [this%mu, this%lambda, this%alpha, this%beta]
  End Function posterior_normalInverseGamma_getParameters

  Integer Function posterior_normalInverseGamma_withParameters(this, X) Result(info)
    class(mlf_posterior_normalInverseGamma), intent(inout) :: this
    real(c_double), intent(in) :: X(:)
    info = 0
    this%mu = X(1); this%lambda = X(2); this%alpha = X(3); this%beta = X(4)
  End Function posterior_normalInverseGamma_withParameters

  Elemental Real(c_double) Function posterior_normalInverseGamma_computePDF(this, x) Result(y)
    class(mlf_posterior_normalInverseGamma), intent(in) :: this
    real(c_double), intent(in) :: x
    real(c_double) :: a, b, l
    ASSOCIATE(alpha => this%alpha, beta => this%beta, lambda => this%lambda, mu => this%mu)
      a = alpha + 0.5d0
      l = lambda + 1d0
      b = beta + 0.5d0*lambda/(lambda+1)*(x-mu)**2
      y = SQRT(lambda)*beta**alpha*GAMMA(a)/(SQRT(2d0*mlf_PI*l)*b**a*GAMMA(alpha))
    END ASSOCIATE
  End Function posterior_normalInverseGamma_computePDF

  Elemental Real(c_double) Function posterior_normalInverseGamma_computeLogPDF(this, x) Result(y)
    class(mlf_posterior_normalInverseGamma), intent(in) :: this
    real(c_double), intent(in) :: x
    real(c_double) :: a, b, l
    ASSOCIATE(alpha => this%alpha, beta => this%beta, lambda => this%lambda, mu => this%mu)
      a = alpha + 0.5d0
      l = lambda + 1d0
      b = beta + 0.5d0*lambda/(lambda+1)*(x-mu)**2
      y = alpha*LOG(beta) - a*LOG(b) + LOG_GAMMA(a) - LOG_GAMMA(alpha) &
        + 0.5d0*(LOG(lambda) - LOG(l) - LOG(2d0*mlf_PI))
    END ASSOCIATE
  End Function posterior_normalInverseGamma_computeLogPDF

  Real(c_double) Function posterior_normalInverseGamma_getStats(this, statType) Result(y)
    class(mlf_posterior_normalInverseGamma), intent(in) :: this
    integer, intent(in) :: statType
    ASSOCIATE(alpha => this%alpha, beta => this%beta, lambda => this%lambda, mu => this%mu)
      Select Case(statType)
      Case (mlf_dist_mode, mlf_dist_median, mlf_dist_mean)
        y = mu
      Case Default
        y = IEEE_VALUE(y, IEEE_QUIET_NAN)
      End Select
    END ASSOCIATE
  End Function posterior_normalInverseGamma_getStats

  Integer Function posterior_normalInverseGamma_fitWithData(this, Points, W, prior) Result(info)
    class(mlf_posterior_normalInverseGamma), intent(inout) :: this
    real(c_double), intent(in) :: Points(:)
    real(c_double), intent(in), optional :: W(:)
    class(mlf_distribution_abstract), optional, intent(in) :: prior
    real(c_double) :: sN
    info = -1
    If(.NOT. PRESENT(prior)) RETURN
    Select Type(prior)
    Class is (mlf_distribution_normalInverseGamma)
      sN = REAL(SIZE(Points),8)
      this%alpha = prior%alpha + sN/2
      this%beta = prior%beta + 0.5d0*SUM(Points**2) + 0.5d0*prior%lambda*prior%mu**2 &
                - 0.5d0*(prior%lambda*prior%mu + SUM(Points))**2/(prior%lambda + sN)
      this%lambda = prior%lambda + sN
      this%mu = (prior%lambda*prior%mu + SUM(Points))/(prior%lambda + sN)
      info = 0
    End Select
  End Function posterior_normalInverseGamma_fitWithData

  Real(c_double) Function normalInverseGamma_computePDF(this, x) Result(y)
    class(mlf_distribution_normalInverseGamma), intent(in) :: this
    real(c_double), intent(in) :: X(:)
    ASSOCIATE(z => X(1), sigma => X(2), mu => this%mu, lambda => this%lambda, &
        alpha => this%alpha, beta => this%beta)
      y = SQRT(lambda)/(SQRT(2d0*mlf_PI)*sigma)*beta**alpha/GAMMA(alpha)*sigma**(-2*alpha+2) &
        * EXP(-(2d0*beta+lambda*(z-mu)**2)/(2d0*sigma**2))
    END ASSOCIATE
  End Function normalInverseGamma_computePDF

  Real(c_double) Function normalInverseGamma_computeLogPDF(this, X) Result(y)
    class(mlf_distribution_normalInverseGamma), intent(in) :: this
    real(c_double), intent(in) :: X(:)
    ASSOCIATE(z => X(1), sigma => X(2), mu => this%mu, lambda => this%lambda, &
        alpha => this%alpha, beta => this%beta)
      y = 0.5d0*(LOG(lambda) - LOG(2d0*mlf_PI)) - LOG(sigma) + alpha*LOG(beta) - LOG_GAMMA(alpha) &
        + (-2*alpha+2)*LOG(sigma) - (2d0*beta+lambda*(z-mu)**2)/(2d0*sigma**2)
    END ASSOCIATE
  End Function normalInverseGamma_computeLogPDF

  Integer Function normalInverseGamma_fitWithData(this, Points, W, prior) Result(info)
    class(mlf_distribution_normalInverseGamma), intent(inout) :: this
    real(c_double), intent(in) :: Points(:,:)
    real(c_double), intent(in), optional :: W(:)
    class(mlf_distribution_abstract), optional, intent(in) :: prior
    real(c_double) :: meanX, meanS2, varX, varS2, rN, invSumN
    ASSOCIATE(X => Points(1,:), sigma => Points(2,:), &
        mu => this%mu, lambda => this%lambda, alpha => this%alpha, beta => this%beta)
      rN = REAL(SIZE(X), 8)
      If(PRESENT(W)) Then
        invSumN = 1d0/SUM(W)
        meanX = SUM(X*W)*invSumN
        meanS2 = SUM(sigma**2*W)*invSumN
        varX = SUM(W*(X-meanX)**2)*rN/(rN-1)*invSumN
        varS2 = SUM(W*(sigma**2-meanS2)**2)*rN/(rN-1)*invSumN
      Else
        invSumN = 1d0/rN
        meanX = SUM(X)*invSumN
        meanS2 = SUM(sigma**2)*invSumN
        varX = SUM((X-meanX)**2)/(rN-1)
        varS2 = SUM((sigma**2-meanS2)**2)/(rN-1)
      Endif
      mu = meanX
      lambda = meanS2/varX
      alpha = 2d0 + meanS2**2/varS2
      beta = meanS2*(alpha-1)
    END ASSOCIATE
    info = 0
  End Function normalInverseGamma_fitWithData
End Module mlf_normal_inverse_gamma


C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details

      SUBROUTINE VOL2D( COORD, LSTSN, NSEG, VOLUME, NDIM, NUMESS, AXI,
     *   CENT, NUMNP, CENTER)

C***********************************************************************

C     DESCRIPTION:
C       This routine computes the volume of a cavity formed
C       by the boundary of an element side set flag

C     FORMAL PARAMETERS:
C       COORD   REAL      Nodal Coordinates
C       LSTSN   INTEGER   List of nodes on this boundary
C       NSEG    INTEGER   Number of segments in this boundary
C       VOLUME  REAL      Volume of this cavity
C       NDIM    INTEGER   Number of Dimensions
C       NUMESS  INTEGER   Number of Element Side Set Flags
C       AXI     LOGICAL   TRUE if axisymmetric mesh
C       CENT    REAL      Apex of volume triangles

C     CALLED BY:

C***********************************************************************

      LOGICAL AXI, CENTER
      DIMENSION COORD(NUMNP, *), LSTSN(*), CENT(2)
      TWOPI = 2.0 * ATAN2(0.0, -1.0)

      VOLUME = 0.0

C ... CALCULATE APPROXIMATE CENTROID OF CAVITY.  ASSUME XC ON
C     SYMMETRY AXIS.

      IF (.NOT. CENTER) THEN
         DO 10 KSEG = 1 , 2*NSEG
             J = LSTSN(KSEG)

             CENT(2) = CENT(2) + COORD(J,2)
   10    CONTINUE
         CENT(2) = CENT(2) / (2 * NSEG)
      END IF

      DO 20 KSEG = 1 , NSEG
          J = LSTSN(2*KSEG)
          I = LSTSN(2*KSEG - 1)

          X1 = COORD(I,1) - CENT(1)
          X2 = COORD(J,1) - CENT(1)

          Y1 = COORD(I,2) - CENT(2)
          Y2 = COORD(J,2) - CENT(2)

          VP = (Y1 * X2 - Y2 * X1) / 2.0
          IF (AXI) THEN
              XC = (X1 + X2) / 3.0
              VP = TWOPI * XC * VP
          END IF
          VOLUME = VOLUME + VP
   20 CONTINUE

      RETURN
      END


Module units
  !!-----------------------------------------------------------------------
  !!
  !! Module to handle unit conversion
  !!
  !! author - j.wilkins march 2020
  !!-----------------------------------------------------------------------

  Use hash, only: hash_table, STR_LEN, error
  Use, intrinsic :: iso_fortran_env, only : dp => real64
  Implicit None

  Private

  Type, Private, Extends(hash_table) :: units_hash_table
   contains
     Generic  , Public  :: get => get_int, get_double, get_complex, get_unit
     Procedure, Private :: get_unit
  end type units_hash_table

  Type, Private :: unit_data
     !! Type containing data corresponding to units
     Character(Len=STR_LEN) :: name
     Character(Len=STR_LEN) :: abbrev
     Real(Kind=dp) :: conversion_to_si
     Integer, Dimension(7) :: dims = [0, 0, 0, 0, 0, 0, 0] ! mass length time temp mol current luminosity
   contains
     Generic, Public :: Operator(*) => unit_mult
     Generic, Public :: Operator(/) => unit_div
     Generic, Public :: Operator(**) => unit_pow
     Procedure, Pass, Private :: unit_mult, unit_div, unit_pow
     Procedure, Nopass :: init => init_unit
  end type unit_data

  Public :: initialise_units
  Public :: convert_units

  Type(unit_data), Private, Parameter :: null_unit = unit_data('', '', 1.0_dp)
  type(units_hash_table), Private, save :: units_table

contains

  Subroutine initialise_units()
    !!-----------------------------------------------------------------------
    !!
    !! Set up units table call before attempting to convert
    !!
    !! author - j.wilkins march 2020
    !!-----------------------------------------------------------------------
    Real(kind=dp), Parameter :: electron_charge = 1.602176634e-19_dp
    Real(kind=dp), Parameter :: coulomb = 1.0_dp
    Real(kind=dp), Parameter :: avogadro = 6.022140857e23_dp
    Real(kind=dp), Parameter :: boltz = 1.3806503e-23_dp ! JK-1

    Real(kind=dp), Parameter :: metre = 1.0_dp
    Real(kind=dp), Parameter :: angstrom = 1.0e-10_dp*metre
    Real(kind=dp), Parameter :: bohr = 0.52918_dp*angstrom
    Real(kind=dp), Parameter :: inch = 2.54e-2_dp*metre

    Real(kind=dp), Parameter :: parsec = 3.0856775999999956e16_dp*metre

    Real(kind=dp), Parameter :: joule = 1.0_dp
    Real(kind=dp), Parameter :: calorie = 4.1842_dp*joule
    Real(kind=dp), Parameter :: hartree = 4.359744722e-18_dp*joule

    Real(kind=dp), Parameter :: kilogram = 1.0_dp
    Real(kind=dp), Parameter :: amu = 1.660539e-21_dp*kilogram
    Real(kind=dp), Parameter :: electron_mass = 9.1093837015e-31_dp*kilogram
    Real(kind=dp), Parameter :: pound = 0.45359237_dp*kilogram

    Real(kind=dp), Parameter :: second = 1.0_dp
    Real(kind=dp), Parameter :: aut = 2.4188843265857e-17_dp*second

    Real(kind=dp), Parameter :: newton = kilogram*metre/second**2

    Real(kind=dp), Parameter :: atmosphere = 101325.0_dp

    Real(kind=dp), Parameter :: pascal = newton/metre**2

    Real(kind=dp), Parameter :: gravity = 9.81_dp*metre/second**2

    call units_table%init(100)

    ! Time

    call units_table%set("hr", init_unit(abbrev="hr", name="Hour", time=1, to_si=3600.0_dp*second))
    call units_table%set("min", init_unit(abbrev="min", name="Minute", time=1, to_si=60.0_dp*second))
    call units_table%set("s", init_unit(abbrev="s", name="Second", time=1, to_si=second))
    call units_table%set("aut", init_unit(abbrev="aut", name="Atomic Time Unit", time=1, to_si=aut))
    call units_table%set("giffy", init_unit(abbrev="giffy", name="Giffy", time=1, to_si=1e-2*second))
    call units_table%set("shake", init_unit(abbrev="shake", name="Shakes of a lamb's tail", time=1, to_si=1e-8*second))

    ! Length

    call units_table%set("ang", init_unit(abbrev="ang", name="Angstrom", length=1, to_si=angstrom))
    call units_table%set("bohr", init_unit(abbrev="bohr", name="Bohr", length=1, to_si=bohr))
    call units_table%set("m", init_unit(abbrev="m", name="Metre", length=1, to_si=metre))
    call units_table%set('in', init_unit(abbrev="in", name="Inch", length=1, to_si=inch))
    call units_table%set("ft", init_unit(abbrev="ft", name="Foot", length=1, to_si=12.0_dp*inch))
    call units_table%set("pc", init_unit(abbrev="pc", name="Parsec", length=1, to_si=parsec))
    call units_table%set("bus", init_unit(abbrev="bus", name="London Bus", length=1, to_si=2.5_dp*metre))

    ! Mass

    call units_table%set("da", init_unit(abbrev="Da", name="Atomic Mass Unit", mass=1, to_si=amu))
    call units_table%set("amu", init_unit(abbrev="amu", name="Atomic Mass Unit", mass=1, to_si=amu))
    call units_table%set("g", init_unit(abbrev="g", name="Gram", mass=1, to_si=1e-3*kilogram))
    call units_table%set("lb", init_unit(abbrev="lb", name="Pound", mass=1, to_si=pound))
    call units_table%set("oz", init_unit(abbrev="oz", name="Ounce", mass=1, to_si=pound/16.0_dp))
    call units_table%set("m_e", init_unit(abbrev="m_e", name="Electron mass", mass=1, to_si=electron_mass))
    call units_table%set("whale", init_unit(abbrev="Whale", name="Blue Whale Mass", mass=1, to_si=100e3_dp*kilogram))

    ! Charge

    call units_table%set("q_e", &
         & init_unit(abbrev="q_e", name="Elementary charge", current=1, time=1, to_si=electron_charge))
    call units_table%set("e", &
         & init_unit(abbrev="e", name="Elementary charge", current=1, time=1, to_si=electron_charge))
    call units_table%set("c", &
         & init_unit(abbrev="C", name="Coulomb", current=1, time=1, to_si=coulomb))

    ! Energy

    call units_table%set("j", init_unit(abbrev="J", name="Joule", mass=1, length=2, time=-2, to_si=joule))
    call units_table%set("cal", &
         & init_unit(abbrev="Cal", name="Calorie", mass=1, length=2, time=-2, to_si=calorie))
    call units_table%set("ha", init_unit(abbrev="Ha", name="Hartree", mass=1, length=2, time=-2, to_si=hartree))
    call units_table%set("e_h", init_unit(abbrev="Ha", name="Hartree", mass=1, length=2, time=-2, to_si=hartree))
    call units_table%set("ry", init_unit(abbrev="Ry", name="Rydberg", mass=1, length=2, time=-2, to_si=0.5_dp*hartree))
    call units_table%set("littleboy", init_unit(abbrev="littleboy", name="Little Boy", &
         & mass=1, length=2, time=-2, to_si=6.3E+13*joule))

    ! Temperature

    call units_table%set("k", init_unit(abbrev="K", name="Kelvin", temp=1, to_si=1.0_dp))

    ! Energy flow
    call units_table%set("w", init_unit(abbrev="W", name="Watt", mass=1, length=2, time=-3, to_si=joule/second))

    ! Area

    call units_table%set("wales", init_unit(abbrev="Wales", name="Are of Wales", length=2, to_si= 2.07350E10_dp*metre**2))
    call units_table%set("barn", init_unit(abbrev="barn", name="Barn", length=2, to_si=1e-28_dp*metre**2))

    ! Pressure

    call units_table%set("atm", init_unit(abbrev="atm", name="Atmosphere", mass=1, length=-1, time=-2, to_si=atmosphere))
    call units_table%set("pa", init_unit(abbrev="Pa", name="Pascal", mass=1, length=-1, time=-2, to_si=pascal))

    ! Force

    call units_table%set("n", &
         & init_unit(abbrev="N", name="Newton", mass=1, length=1, time=-2, to_si=newton))
    call units_table%set("dyn", &
         & init_unit(abbrev="dyn", name="Dyne", mass=1, length=1, time=-2, to_si=1e5_dp*newton))

    ! Velocity

    call units_table%set("auv", &
         & init_unit(abbrev="auv", name="Atomic Velocity Unit", length=1, time=-1, to_si=bohr/aut))
    call units_table%set("beard", &
         & init_unit(abbrev="beard", name="Beard growth", length=1, time=-1, to_si=5e-9*metre/second))

    ! Constants
    call units_table%set("grav", &
         & init_unit(abbrev="g_e", name="9.81 m/s^2", length=1, time=-2, to_si=gravity))
    call units_table%set("k_b", &
         & init_unit(abbrev='k_b', name="Boltzmann Constant", mass=1, length=2, time=-2, temp=-1, to_si=boltz))

    ! Voltage

    call units_table%set("v", init_unit(abbrev="V", name="Volt", mass=1, length=2, time=-3, current=-1, &
         & to_si=joule/coulomb))

    ! Mols

    call units_table%set("mol", init_unit(abbrev="mol", name="Mole", mol=1, to_si=avogadro))

    ! Unitless

    call units_table%set("%", init_unit(abbrev="%", name="%", to_si=100.0_dp))
    call units_table%set("", init_unit(abbrev="", name="", to_si=1.0_dp))

  End Subroutine initialise_units

  Function convert_units(val, from, to) result(res)
    Real(kind=dp), Intent(in) :: val
    Real(kind=dp) :: res
    Character(Len=*) :: from, to
    Type( unit_data ) :: from_unit, to_unit
    Type( unit_data ) :: output

    output = output%init("", "", 1.0_dp)
    from_unit = parse_unit_string(from)
    to_unit = parse_unit_string(to)
    output = to_unit / from_unit
    if (any(output%dims /= 0)) call error('Cannot convert between '//trim(from)//' & '//trim(to)//' different dimensions')
    res = val / output%conversion_to_si

  end Function convert_units

  Subroutine handle_decimal_prefix(string, factor)
    Character(len=*), Intent(inout) :: string
    Integer :: i
    Type(unit_data), intent(out) :: factor
    Character(Len=256) :: tmp
    Character(len=*), Parameter :: prefix_symbol = "YZEPTGMk dcmunpfazy"
    Type(unit_data), Dimension(19), Parameter :: prefix = [ &
         & unit_data(name="Yotta", abbrev="Y", conversion_to_si=1e24_dp), &
         & unit_data(name="Zetta", abbrev="Z", conversion_to_si=1e21_dp), &
         & unit_data(name="Exa",   abbrev="E", conversion_to_si=1e18_dp), &
         & unit_data(name="Peta",  abbrev="P", conversion_to_si=1e15_dp), &
         & unit_data(name="Tera",  abbrev="T", conversion_to_si=1e12_dp), &
         & unit_data(name="Giga",  abbrev="G", conversion_to_si=1e9_dp), &
         & unit_data(name="Mega",  abbrev="M", conversion_to_si=1e6_dp), &
         & unit_data(name="Kilo",  abbrev="k", conversion_to_si=1e3_dp), &
         & null_unit, &
         & unit_data(name="Deci",  abbrev="d", conversion_to_si=1e-1_dp), &
         & unit_data(name="Centi", abbrev="c", conversion_to_si=1e-2_dp), &
         & unit_data(name="Milli", abbrev="m", conversion_to_si=1e-3_dp), &
         & unit_data(name="Micro", abbrev="u", conversion_to_si=1e-6_dp), &
         & unit_data(name="Nano",  abbrev="n", conversion_to_si=1e-9_dp), &
         & unit_data(name="Pico",  abbrev="p", conversion_to_si=1e-12_dp), &
         & unit_data(name="Femto", abbrev="f", conversion_to_si=1e-15_dp), &
         & unit_data(name="Atto",  abbrev="a", conversion_to_si=1e-18_dp), &
         & unit_data(name="Zepto", abbrev="z", conversion_to_si=1e-21_dp), &
         & unit_data(name="Yocto", abbrev="y", conversion_to_si=1e-24_dp)]

    factor = null_unit
    tmp = string(2:)
    call lower_case(tmp)
    if (.not. units_table%in(tmp)) then
       i = index(prefix_symbol, string(2:2))
       tmp = string(3:)
       call lower_case(tmp)
       if (i < 1 .or. .not. units_table%in(tmp)) call error("Unit not found "//string(2:))
       factor = prefix(i)
       string = string(1:1) // string(3:)
    end if

  end Subroutine handle_decimal_prefix

  Function parse_unit_string(string) result(output)
    Type( unit_data ) :: output
    Type( unit_data ) :: tmp_unit
    Character(Len=*), Intent ( in ) :: string
    Character(Len=256) :: curr_parse
    Character(Len=256), Dimension(:), Allocatable :: parsed
    Character(Len=*), Parameter :: number = "1234567890-+"
    Type(unit_data) :: factor
    Integer :: i
    Integer :: n

    call decompose_unit_string("."//string, parsed)

    output = null_unit

    ! Handle powers first
    do i = size(parsed), 1, -1
       curr_parse = parsed(i)
       if (curr_parse(1:1) == "^") then
          if (verify(trim(curr_parse(2:)), number) /= 0) call error("Non numeric power issued")
          read(curr_parse(2:), "(i8.1)") n
          curr_parse = parsed(i-1)
          call handle_decimal_prefix(curr_parse, factor)
          call lower_case(curr_parse)
          call units_table%get(curr_parse(2:), tmp_unit)
          tmp_unit = (factor*tmp_unit) ** n
          select case (curr_parse(1:1))
          case (".")
             output = output * tmp_unit
          case ("/")
             output = output / tmp_unit
          case default
             call error("Cannot parse unit string"//string)
          end select
          parsed(i) = "."
          parsed(i-1) = "."
       end if
    end do

    do i = 1, size(parsed)
       curr_parse = parsed(i)
       call handle_decimal_prefix(curr_parse, factor)
       call lower_case(curr_parse)
       call units_table%get(curr_parse(2:), tmp_unit)

       select case (curr_parse(1:1))
       case (".")
          output = output * (factor * tmp_unit)
       case ("/")
          output = output / (factor * tmp_unit)
       case default
          call error("Cannot parse unit string "//string)
       end select
    end do

    output%abbrev = string

  end Function parse_unit_string

  Subroutine decompose_unit_string(string, output)
    Character(Len=256), Dimension(:), Allocatable :: output
    Character(Len=*), Intent( In ) :: string
    Character(Len=*), Parameter :: alphabet = "+-1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_%'"//'"'
    Character(Len=*), Parameter :: punc = "./^"
    Integer :: nParts
    Integer :: i, j, k
    Integer :: ierr

    ierr = 0
    if (allocated(output)) deallocate(output, stat=ierr)
    if (ierr /= 0) call error("Error deallocating output in decompose_unit_string")

    nParts = count([(verify(string(j:j), punc) == 0, j=1,len(string))])
    allocate(output(nParts), stat=ierr)
    if (ierr /= 0) call error("Error allocating output in decompose_unit_string")

    j = 1
    do i = 1, nParts
       k = verify(string(j+1:), alphabet)
       if (k == 0) then
          k = len(string) + 1
       else
          k = j+k
       end if
       output(i) = string(j:k-1)
       j = k
    end do
  end Subroutine decompose_unit_string

  type(unit_data) Function unit_mult(a, b)
    Class(unit_data), Intent( in ) :: a, b

    unit_mult = unit_data( &
         name = trim(a%name)//" "//b%name, &
         abbrev = trim(a%abbrev)//b%abbrev, &
         conversion_to_si = a%conversion_to_si*b%conversion_to_si, &
         dims = a%dims + b%dims &
         )
  end Function unit_mult

  type(unit_data) Function unit_div(a, b)
    Class(unit_data), Intent( in ) :: a, b

    unit_div = unit_data( &
         name = trim(a%name)//" per "//b%name, &
         abbrev = trim(a%abbrev)//"/"//b%abbrev, &
         conversion_to_si = a%conversion_to_si/b%conversion_to_si, &
         dims = a%dims - b%dims &
         )
  end Function unit_div

  type(unit_data) Function unit_pow(a, b)
    Class(unit_data), Intent( in ) :: a
    Integer, Intent( in ) :: b
    Character(Len=8) :: b_str

    write(b_str, "(i0.1)") b

    unit_pow = unit_data( &
         name = trim(a%name)//"^"//trim(b_str), &
         abbrev = trim(a%abbrev)//"^"//trim(b_str), &
         conversion_to_si = a%conversion_to_si**b, &
         dims = a%dims*b &
    )

  end Function unit_pow

  type(unit_data) Function init_unit(name, abbrev, to_si, mass, length, time, temp, mol, current, luminosity)
    Character(Len = *), Intent( In    ) :: name, abbrev
    Real(Kind = dp), Intent( In    ) :: to_si
    Integer, Optional, Intent( In    ) :: mass, length, time, temp, mol, current, luminosity

    init_unit = unit_data(name=name, abbrev=abbrev, conversion_to_si=to_si)
    if (present(mass)) then
       init_unit%dims(1) = mass
    end if

    if (present(length)) then
       init_unit%dims(2) = length
    end if

    if (present(time)) then
       init_unit%dims(3) = time
    end if

    if (present(temp)) then
       init_unit%dims(4) = temp
    end if

    if (present(mol)) then
       init_unit%dims(5) = mol
    end if

    if (present(current)) then
       init_unit%dims(6) = current
    end if

    if (present(luminosity)) then
       init_unit%dims(7) = luminosity
    end if

  end Function init_unit

  Subroutine get_unit( table, key, val, default )
    !!-----------------------------------------------------------------------
    !!
    !! get unit type from hash table
    !!
    !! author    - i.j.bush april 2020
    !!-----------------------------------------------------------------------

    Implicit None

    Class( units_hash_table ), Intent( InOut ) :: table
    Character(Len=*), Intent( In    ) :: key
    type(unit_data)            , Intent(   Out ) :: val
    type(unit_data), Intent( In    ), Optional :: default
    Class( * ), Pointer :: stuff

    call table%get_cont(key, default, stuff)

    Select Type( stuff )
    Type is ( unit_data )
       val = stuff
    Class Default
       Call error('Trying to get unit from a not unit')
    End Select

    deallocate(stuff)
    nullify(stuff)

  End Subroutine get_unit

  Subroutine lower_case(str)
    Character(len=*), Intent( InOut ) :: str
    Integer :: i

    do i = 1, len_trim(str)
       Select Case(str(i:i))
       Case ('A':'Z')
          str(i:i) = achar( ichar(str(i:i)) + 32 )
       Case default
          continue
       end Select
    end do
  end Subroutine lower_case

end Module units


      SUBROUTINE vertex_e16(PX,PY,PZ,VX0,VY0,VZ0,VX,VY,VZ)
C
C     PROGRAM CORRECTS THE VERTEX
C     USING THE X AND Y BEAM POSITION OF E1-6 RUN
C     FUNCTIONS X_BEAM and Y_BEAM deliver X,Y
C     beam coordinates
C
C     PX,PY,PZ    - MOMENTUM OF THE PARTICLE
C     VX0,VY0,VZ0 - OLD VERTEX COORDINATES (from ntuple)
C     VX,VY,VZ    - NEW VERTEX COORDINATES
C
C Valery Kubarovsky  Nov 25, 2002
C                    Mar 22, 2003 found bug in the VY calculation
C
C

      IMPLICIT NONE
      REAL PX,PY,PZ,VX0,VY0,VZ0,VX,VY,VZ
      DOUBLE PRECISION N(3,6)
      DATA N /
     *       1.0000, 0.000000000, 0.0,
     *       0.5000, 0.866025388, 0.0,
     *      -0.5000, 0.866025388, 0.0,
     *      -1.0000, 0.000000000, 0.0,
     *      -0.5000,-0.866025388, 0.0,
     *       0.5000,-0.866025388, 0.0 /
      SAVE N
      REAL X_BEAM, Y_BEAM
      DOUBLE PRECISION PHI,PHI1,X0,Y0,Z0,SP,SV,S0,A
      INTEGER SECTOR

      PHI1=ATAN2(PY,PX)*180./3.14159
      IF(PHI1.GE.-30.) THEN
          PHI = PHI1+30.
      ELSE
          PHI = PHI1+390
      ENDIF
      SECTOR=INT(PHI/60.)+1

      X0=X_BEAM()
      Y0=Y_BEAM()
      z0=0.

c     S0 =  X0*N(1,SECTOR)+ Y0*N(2,SECTOR)+ Z0*N(3,SECTOR)
c     SP =  PX*N(1,SECTOR)+ PY*N(2,SECTOR)+ PX*N(3,SECTOR)
c     SV = VX0*N(1,SECTOR)+VY0*N(2,SECTOR)+VX0*N(3,SECTOR)

      S0 =  X0*N(1,SECTOR)+ Y0*N(2,SECTOR)
      SP =  PX*N(1,SECTOR)+ PY*N(2,SECTOR)
      SV = VX0*N(1,SECTOR)+VY0*N(2,SECTOR)

      IF(SP.EQ.0.) THEN
         VX=VX0
         VY=VY0
         VZ=VZ0
      ELSE
         A=(S0-SV)/SP
         VX=VX0+A*PX
         VY=VY0+A*PY
         VZ=VZ0+A*PZ
      ENDIF

      RETURN
      END

C-----

      REAL FUNCTION X_BEAM()
      IMPLICIT NONE
      X_BEAM = 0.090
      RETURN
      END

C-----

      REAL FUNCTION Y_BEAM()
      IMPLICIT NONE
      Y_BEAM = -0.345
      RETURN
      END


*     ------------------------------------------------------------------
*              H N O R M
*     ------------------------------------------------------------------
*
*       Returns the value of the normalization constant for an (nl)
*   hydrogenic function with nuclear charge ZZ.
*
*
      DOUBLE PRECISION FUNCTION HNORM(N,L,ZZ)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID
     :   ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS
      M = L + L + 1
      A = N + L
      B = M
      T = A
      D = B
      M = M - 1
      IF (M .EQ. 0) GO TO 2
      DO 1 I = 1,M
      A = A - D1
      B = B - D1
      T = T*A
1     D = D*B
2     HNORM = DSQRT(ZZ*T)/( N*D)
      RETURN
      END


c
c     Computes portmanteau statistic for multivariate time series
c     regression for a ik-dimensional process.
c
c    The program has been checked, but some errors may exist.
c    It is intended for use in my courses only. Ruey S. Tsay, December 1990.
c
      implicit double precision(a-h,o-z)
      parameter(mxn=100000, id=10, mlag = 120)

      dimension e(mxn,id), cov(id,id), corr(id,id),
     *     trcorr(id,id), sigma(id,id), esq(mxn,id)
      dimension siginv(id,id)

c     Read in data
c
      call setup(e,mxn,nob,id,ik,nlag,npar)
c
c  remove sample means
c
      do i=1, ik
       ave  = 0.0d0
       do  j=1, nob
        ave = ave + e(j,i)
       enddo
       ave = ave/dfloat(nob)
       do j=1, nob
        e(j,i) = e(j,i) - ave
       enddo
      enddo
c
      write(6,41)
 41   format(1x,'Compute Q-stat for the squared series? (1=y): ',$)
      read(5,*) isq
c
      if(isq .ne. 1)go to 45
c------------- square series
      do i=1, ik
       do it=1, nob
        esq(it,i) = e(it,i)*e(it,i)
       enddo
      enddo
c
c  remove sample means
c
      do i=1, ik
       ave  = 0.0d0
       do  j=1, nob
        ave = ave + esq(j,i)
       enddo
       ave = ave/dfloat(nob)
       do j=1, nob
        esq(j,i) = esq(j,i) - ave
       enddo
      enddo
c
 45   continue
      print*,'Output file: fort.36'

      tt = dlog(dfloat(nob))
      idlag=ifix(tt)

      write(36,*)'Suggested # of Lags = ',idlag
c      print*,'Idea # of lags = ',idlag
c
c     Compute sample covariance matrix

      call covar(e,sigma,mxn,nob,id,ik,0)
c
      call mtinv(sigma,siginv,id,ik)
c
      q = 0.0d0
      qcross = 0.0d0

      iend = nlag
      if(iend .gt. mlag)iend= mlag
c
      write(36,38)
 38   format(2x,'m',7x,'Orig-Q',7x,'LM-Q',7x,'LB-Q',5x,'d.f.')
      do it = 1, iend
        call covar(e,cov,mxn,nob,id,ik,it)
        call correlation(cov,corr,trcorr,siginv,id,ik)
        call mult(corr,trcorr,trace,trcross,mxn,nob,id,ik,it)
        q = q + trace
        qcross = qcross + trcross
        qstar = q + dfloat((ik**2)*it*(it+1))/(2.0d0*dfloat(nob))
        idf = it*ik*ik-npar
        if(idf .lt. 0)idf = 0
c
        write(36,37) it, q, qstar, qcross, idf
      enddo
   37   format(1x,i3,1x,3f12.4,i5)
cc****
c*** squared series
c****
      if(isq .ne. 1)stop
       write(36,42)
 42    format(1x,'*** For squared series *** ')
c
c     Compute sample covariance matrix of the squared series

      call covar(esq,sigma,mxn,nob,id,ik,0)
c
      call mtinv(sigma,siginv,id,ik)
c
      q = 0.0d0
      qcross = 0.0d0
c
      write(36,38)
      do it = 1, iend
        call covar(esq,cov,mxn,nob,id,ik,it)
        call correlation(cov,corr,trcorr,siginv,id,ik)
        call mult(corr,trcorr,trace,trcross,mxn,nob,id,ik,it)
        q = q + trace
        qcross = qcross + trcross
        qstar = q + dfloat((ik**2)*it*(it+1))/(2.0d0*dfloat(nob))
        idf = it*ik*ik-npar
        if(idf .le. 0)idf = 0
c
        write(36,37) it, q, qstar, qcross, idf
      enddo
c
      stop
      end

c------------------------------------------------------------------
      subroutine covar(resid,c,n,nob,id,ik,lag)
      implicit double precision(a-h,o-z)
c
c     Computes covariance matrices

      dimension resid(n,id), c(id,id)

      do i = 1,ik
        do j = 1,ik
          c(i,j) = 0.0d0
        enddo
      enddo

      do i = 1,ik
        do j = 1,ik
          accu=0.0d0
          do k = lag + 1, nob
            accu = accu + resid(k,i)*resid(k-lag,j)
          enddo
          c(i,j) = accu
        enddo
      enddo

c     Divide matrix by number of observations, n

      do i = 1,ik
        do j = 1,ik
          c(i,j) = c(i,j)/dfloat(nob)
        enddo
      enddo

      return
      end

c------------------------------------------------------------------

      subroutine correlation(c,r,rt,sinv,id,ik)
      implicit double precision(a-h,o-z)
c
c     Computes correlation matrices

      dimension c(id,id), r(id,id), rt(id,id), sinv(id,id)

c     Compute r = Rk

      do i = 1,ik
        do j = 1,ik
          r(i,j) = 0.0d0
        enddo
      enddo

      do i = 1,ik
        do j = 1,ik
          do k = 1,ik
c            r(i,j) = r(i,j) + sinv(i,k)*c(k,j)
            r(i,j) = r(i,j) + c(i,k)*sinv(k,j)
          enddo
        enddo
      enddo

c     Compute rt = R-k

      do i = 1,ik
        do j = 1,ik
          rt(i,j) = 0.0d0
        enddo
      enddo

      do i = 1,ik
        do j = 1,ik
          do k = 1,ik
c            rt(i,j) = rt(i,j) + sinv(i,k)*c(j,k)
            rt(i,j) = rt(i,j) + c(k,i)*sinv(k,j)
          enddo
        enddo
      enddo

      return
      end

c------------------------------------------------------------------

      subroutine mult(r,rt,sum,sumcr,n,nob,id,ik,lag)
c
      implicit double precision(a-h,o-z)
c
c     Multiplies r and rt, computes trace, then multiplies by n.
c
      parameter(m=10)
      dimension r(id,id), rt(id,id), temp(m,m)

c     Multiply r and rt:

      do i = 1,ik
        do j = 1,ik
          temp(i,j) = 0.0d0
        enddo
      enddo

      do i = 1,ik
        do j = 1,ik
          do k = 1,ik
c            temp(i,j) = temp(i,j) + r(i,k)*rt(k,j)
            temp(i,j) = temp(i,j) + rt(i,k)*r(k,j)
          enddo
        enddo
      enddo

c     Compute trace

      sum = 0.0d0

      do i = 1,ik
        sum = sum + temp(i,i)
      enddo

      sumcr = (dfloat(nob*nob))*(sum/(dfloat(nob-lag)))

      sum = sum*dfloat(nob)

      return
      end

c---------------------------------------------------------------

      subroutine setup(resid,n,nob,id,k,nlag,npar)
      implicit double precision(a-h,o-z)

c     Read in residuals

      dimension resid(n,id), jdx(10)
      character*40  fname
c
      write(6,1)
    1 format(1x,'residual (data) file_name: ',$)
      read(5,2) fname
    2 format(a40)

      write(6,3)
    3 format(1x,'#(columns) in the data file: ',$)
      read(5,*) nc
      write(6,34)
 34   format(1x,'#(parameters) if a model was fit: ',$)
      read(5,*) npar
      write(6,35)
 35   format(1x,'maximum number of CCM mtx: ',$)
      read(5,*) nlag
      if(nlag.le.0)nalg = 12
      if(npar.le.0)npar = 0
c
      open(21,file=fname,status='old')

      nob = 0
      do 10 i = 1,n
        read (21,*,end=11) (resid(i,j), j=1,nc)
         nob = nob+1
 10     continue
 11     close(21)
c
       print*,'nob = ', nob
c
      write(6,4)
 4    format(1x,'The number of series: ',$)
      read(5,*) k

      if(k.eq.nc)return
      write(6,5) k
 5    format(1x,'Input',i3,' locators of residual series: ',$)
      read(5,*) (jdx(i),i=1,k)
c
      do 15 i=1, nob
       do 13 j=1, k
 13       resid(i,j) = resid(i,jdx(j))
 15       continue
c
      return
      end
C*******************************************************************
      SUBROUTINE MTINV(A,DA,IDM,IDIM)
C***********************************************************************
C     MTINV COMPUTES THE INVERSE MATIRX OF A
C**********************************************************************
C****
      implicit double precision(a-h,o-z)
      dimension A(IDM,IDM),DA(IDM,IDM)
C****
      DETA=1.0D0
      IF(IDIM .EQ. 1) GO TO 600
C****
      DO 100 I=1,IDIM
      DO 100 J=1,IDIM
  100 DA(I,J)=A(I,J)
C****
  120 DO 500 I=1,IDIM
      PIVOT=DA(I,I)
      DETA=DETA*PIVOT
C****
C**** DIVIDE PIVOT ROW BY PIVOT ELEMENT.
C****
      DA(I,I)=1.0D0
      DPIVOT=PIVOT+1.0D-20
      DPIVOT=DA(I,I)/DPIVOT
      PIVOT=DPIVOT
      DO 200 J=1,IDIM
  200 DA(I,J)=DA(I,J)*PIVOT
C****
C**** REDUCE NON-PIVOT ROWS
C****
  210 DO 500 II=1,IDIM
      IF(II.EQ.I) GO TO 500
      T=DA(II,I)
      DA(II,I)=0.0D0
      DO 300 J=1,IDIM
  300 DA(II,J)=DA(II,J)-DA(I,J)*T
C****
  500 CONTINUE
      RETURN
  600 DA(1,1)=DETA/A(1,1)
      RETURN
      END
C****
C**** END OF 'MTINV'
C****
C***********************************************************************


      PROGRAM CCPPKCL
C
C Define the error file, the Fortran unit number, the workstation type,
C and the workstation ID to be used in calls to GKS routines.
C
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)   ! NCGM
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=8,  IWKID=1)   ! X Windows
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=11, IWKID=1)   ! PDF
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=20, IWKID=1)   ! PostScript
C
      PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)

      PARAMETER (K=40,N=40,LRWK=1000,LIWK=1000)
      REAL ZREG(K,N), RWRK(LRWK)
      INTEGER M, NOCL, IWRK(LIWK)

      CALL GETDAT (ZREG, K, M, N)
C
C Open GKS
C
      CALL GOPKS (IERRF, ISZDM)
      CALL GOPWK (IWKID, LUNIT, IWTYPE)
      CALL GACWK (IWKID)

      CALL CPSETI('CLS - CONTOUR LEVEL SELECTION FLAG',-20)
      CALL CPRECT(ZREG,K,M,N,RWRK,LRWK,IWRK,LIWK)
C
C Force contour lines to be chosen
C
      CALL CPPKCL (ZREG, RWRK, IWRK)
C
C Get the number of contour levels chosen
C
      CALL CPGETI ('NCL - NUMBER OF CONTOUR LEVELS',NOCL)
      CALL CPSETI ('NCL - NUMBER OF CONTOUR LEVELS',NOCL+1)
      CALL CPSETI ('PAI - PARAMETER ARRAY INDEX',NOCL+1)
      CALL CPSETR ('CLV - CONTOUR LEVEL VALUE',0.0)

      CALL CPBACK(ZREG, RWRK, IWRK)
      CALL CPCLDR(ZREG,RWRK,IWRK)
C
C Close frame and close GKS
C
      CALL FRAME
      CALL GDAWK (IWKID)
      CALL GCLWK (IWKID)
      CALL GCLKS

      STOP
      END

      SUBROUTINE GETDAT (ZREG, K, M, N)
      INTEGER I,J,K,M,N
      REAL ZREG(K,N)

      M=K
      DO 10, I=1,M
         DO 20, J=1,N
            ZREG(I,J)= 10.E-5*(-16.*REAL(I**2*J) +
     +            34*REAL(I*J**2) - REAL(6*I) + 93.)
 20      CONTINUE
 10   CONTINUE

      RETURN
      END


C test for translation of various sub programs
C
C a function sub program
      FUNCTION ifun(arg1, arg2)
      INTEGER arg1, arg2
      ifun = arg1 + arg2
      END
C
C a typed FUNCTION
      DOUBLE PRECISION FUNCTION jfun(arg1)
      DOUBLE PRECISION arg1
      jfun = SQRT(arg1)
      END
C
C subroutine with a stmt function
      SUBROUTINE subr1(a,b)
      DIMENSION arrayA(3,4,3)
      stmtfn(x, y, z) = max(x, max(y, z))
      c = stmtfn(b,a,a)
      arrayA(1,1,1) = c
      write(*,9000),c
9000  format("Value is ",D8.2/)
      RETURN
      END

c subroutine with no args and which calls the functions
      SUBROUTINE subr2
      IMPLICIT DOUBLE PRECISION (l)
      double precision i
      double precision jfun
      integer j, m
      write(*, 9030)
      i=1.
      j=2
      m=3
      l=4.5
      write(*,9010), ifun(j,m)
      write(*,9020), jfun(i+l)
      STOP
9010  FORMAT("IFUN RETURNS ",I3)
9020  FORMAT("JFUN RETURNS ",D8.2)
9030  FORMAT("inside subroutine subr2"/)
      END
C
C main
      PROGRAM TEST
      CALL subr1(3.0, 4.0)
      CALL subr2
      STOP
      END
C


program test_general_bt
  use mod_orrb
  implicit none

  character(len=40) :: test_name
  character(len=*), parameter :: fmt="(A40, 'Time: ',ES8.2,', lbw: ',I3,', error: ',ES8.2, ', ', A10)"

  real(kind=dp) :: t0, t1
  type(error_info) :: error
  integer(kind=int32) :: na, lbwa, ubwa, j
  real(kind=dp), parameter :: tol=1e-14, c=1.5
  !
  real(kind=dp), dimension(:,:), allocatable :: a_d, a0_d, a1_d
  complex(kind=dp), dimension(:,:), allocatable :: a_z, a0_z, a1_z
  type(d_bt), allocatable :: bt_d
  type(z_bt), allocatable :: bt_z

  call initialize_errors

  ! test one
  print *
  print *, "--------------------------------"
  print *
  print *, "Real BT Decomposition Tests"
  print *

  na=40
  lbwa=5; ubwa=3
  bt_d=d_random_bt(na,lbwa,ubwa,error=error)
  a_d=general(bt_d,error)
  a1_d=a_d
  call cpu_time(t0)
  bt_d=bt(a_d,ubwa,lbwa+1,ubwa,tol,error)
  call cpu_time(t1)
  a0_d = general(bt_d,error)
  test_name="Random Real BT;"
  call d_output_result(test_name,a0_d,a1_d,lbwa,bt_d%lbw,t0,t1,c*tol,error)

  na=50
  lbwa=13; ubwa=3
  bt_d=d_random_bt(na,[ (lbwa-1, j=1,na-lbwa), (lbwa, j=na-lbwa+1,na) ], &
       [ (ubwa, j=1,na) ], error=error )
  a_d=general(bt_d,error)
  a1_d=a_d
  bt_d=bt(a_d,ubwa,lbwa+1,ubwa,tol,error)
  call cpu_time(t0)
  a0_d = general(bt_d,error)
  call cpu_time(t1)
  test_name="Random Real Square Termination BT;"
  call d_output_result(test_name,a0_d,a1_d,lbwa,bt_d%lbw,t0,t1,c*tol,error)
  deallocate(bt_d)

  !
  ! Complex BT test
  !
  print *
  print *, "--------------------------------"
  print *
  print *, "Complex BT Decomposition Tests"
  print *

  na=40
  lbwa=5; ubwa=3
  bt_z=z_random_bt(na,lbwa,ubwa,error=error)
  a_z=general(bt_z,error)
  a1_z=a_z
  call cpu_time(t0)
  bt_z=bt(a_z, ubwa, lbwa+1, ubwa, tol,error)
  call cpu_time(t1)
  a0_z=general(bt_z,error)
  test_name="Random Complex BT;"
  call z_output_result(test_name,a0_z,a1_z,lbwa,bt_z%lbw,t0,t1,c*tol,error)

  na=50
  lbwa=13; ubwa=3
  bt_z=z_random_bt(na,[ (lbwa-1, j=1,na-lbwa), (lbwa, j=na-lbwa+1,na) ], &
       [ (ubwa, j=1,na) ], error=error )
  a_z=general(bt_z,error)
  a1_z=a_z
  call cpu_time(t0)
  bt_z=bt(a_z,ubwa,lbwa+1,ubwa,tol,error)
  call cpu_time(t1)
  a0_z = general(bt_z,error)
  test_name="Random Complex Square Termination BT;"
  call z_output_result(test_name,a0_z,a1_z,lbwa,bt_z%lbw,t0,t1,c*tol,error)
  print *

contains

  subroutine d_output_result(name,a0,a1,lbw0,lbw1,t0,t1,bnd,error)
    character(len=*) :: name
    real(kind=dp), dimension(:,:) :: a0, a1
    real(kind=dp) :: bnd, t0, t1
    integer(kind=int32) :: lbw0, lbw1
    type(error_info) :: error

    real(kind=dp) :: berr
    character(len=10) :: test_result

    if (error%code > 0) then
       print *, "Calling error in test: ", name
    else
       berr = maxabs(a1-a0)
       if (lbw0==lbw1 .and. berr < bnd) then
          test_result="PASSED"
       else
          test_result="    FAILED"
       end if
       write (*,fmt) name, t1-t0, lbw1, berr, test_result
    end if
  end subroutine d_output_result

  subroutine z_output_result(name,a0,a1,lbw0,lbw1,t0,t1,bnd,error)
    character(len=*) :: name
    complex(kind=dp), dimension(:,:) :: a0, a1
    real(kind=dp) :: bnd, t0, t1
    integer(kind=int32) :: lbw0, lbw1
    type(error_info) :: error

    real(kind=dp) :: berr
    character(len=10) :: test_result

    if (error%code > 0) then
       print *, "Calling error in test: ", name
    else
       berr = maxabs(a1-a0)
       if (lbw0==lbw1 .and. berr < bnd) then
          test_result="PASSED"
       else
          test_result="    FAILED"
       end if
       write (*,fmt) name, t1-t0, lbw1, berr, test_result
    end if
  end subroutine z_output_result

end program test_general_bt


module mandelbrot_mod

    use iso_c_binding
    use pylogger

    implicit none

    integer,parameter :: mdb_complex_kind = 4
    integer,parameter :: max_iteration    = 252

contains

    subroutine mandelbrot(nx, ny, extent, convergence)
        integer,intent(in) :: nx
        integer,intent(in) :: ny
        real(c_double),intent(in) :: extent(4)

        integer(c_int),allocatable,intent(out) :: convergence(:,:)

        complex(kind=mdb_complex_kind) :: c(nx,ny)
        real(kind=mdb_complex_kind)    :: real_part(nx)
        real(kind=mdb_complex_kind)    :: imag_part(ny)

        real(c_double) :: re_min, re_max, im_min, im_max

        integer i, j

        re_min = extent(1)
        re_max = extent(2)
        im_min = extent(3)
        im_max = extent(4)

        call info( &
            "mandelbrot",                  &
            "begin mandelbrot calculation" &
            )

        allocate( convergence(nx, ny) )

        !$omp parallel
        real_part(:) = (/ (i * re_max + (nx-1-i) * re_min, i=0,nx-1) /) / (nx-1)
        imag_part(:) = (/ (j * im_max + (ny-1-j) * im_min, j=0,ny-1) /) / (ny-1)

        !$omp workshare
        forall (i=1:nx, j=1:ny) &
            c(i, j) = cmplx(real_part(i),imag_part(j), kind=mdb_complex_kind)
        !$omp end workshare

        !$omp workshare
        convergence(:,:) = iteration(c(:,:))
        !$omp end workshare

        !$omp end parallel

        call info( &
            "mandelbrot",                  &
            "end   mandelbrot calculation" &
            )

    contains

        elemental pure integer(c_int) function iteration(c)
            complex(kind=mdb_complex_kind),intent(in) :: c
            complex(kind=mdb_complex_kind)            :: z
            z = (0.d0, 0.d0)
            do iteration = 1, max_iteration
                z = z * z + c
                if (abs(z) > 2) return
            end do
            iteration = -1
        end function iteration

    end subroutine mandelbrot

end module mandelbrot_mod


      PROGRAM LA_SGEEVX_EXAMPLE

!  -- LAPACK95 EXAMPLE DRIVER ROUTINE (VERSION 1.0) --
!     UNI-C, DENMARK
!     DECEMBER, 1999
!
!  .. "Use Statements" ..
      USE LA_PRECISION, ONLY: WP => SP
      USE F95_LAPACK, ONLY: LA_GEEVX
!  .. "Implicit Statement" ..
      IMPLICIT NONE
!  .. "Local Scalars" ..
      INTEGER :: I, J, N, ILO, IHI
      REAL(WP) :: ABNRM
      REAL(WP), ALLOCATABLE :: WR(:), WI(:)
!  .. "Local Arrays" ..
      REAL(WP), ALLOCATABLE :: A(:,:), AA(:,:), VL(:,:), VR(:,:), SCALE(:)
      REAL(WP), ALLOCATABLE :: RCONDE(:), RCONDV(:)
!  .. "Intrinsic Functions" ..
      INTRINSIC REAL, INT
!  .. "Executable Statements" ..
      WRITE (*,*) 'LA_GEEVX Example Program Results'
      N = 5
      ALLOCATE( A(N,N), AA(N,N), WR(N), WI(N), VL(N,N), VR(N,N), SCALE(N) )
      ALLOCATE( RCONDE(N), RCONDV(N) )

      OPEN(UNIT=21,FILE='geev1.ma',STATUS='UNKNOWN')
      DO I=1,N
         DO J=1,N
            READ(21,*) A(I,J)
         ENDDO
      ENDDO
      CLOSE(21)

      AA=A

      WRITE(*,*)'Matrix A:'
      DO I=1,N
         WRITE(*,"(5(I3,1X))") INT(A(I,:))
      ENDDO

      WRITE(*,*) "CALL LA_GEEVX( A, WR, WI, 'B', ILO, IHI, SCALE,", &
                               " ABNRM, RCONDE, RCONDV )"
!      CALL LA_GEEVX( A, WR, WI, VL, VR, 'B', ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV )
!      CALL LA_GEEVX( A, WR, WI, BALANC='B', ILO=ILO, IHI=IHI, SCALE=SCALE, ABNRM=ABNRM,&
!&       RCONDE=RCONDE, RCONDV=RCONDV )
!        RCONDE=RCONDE, RCONDV=RCONDV )

       CALL LA_GEEVX( A, WR, WI, BALANC='B', ILO=ILO, IHI=IHI, &
            SCALE=SCALE, ABNRM=ABNRM, RCONDE=RCONDE, RCONDV=RCONDV )

      WRITE(*,*) "WR on exit : "
      DO I=1,N
         WRITE(*,"((E14.6,1X))") REAL(WR(I))
      ENDDO

      WRITE(*,*) "WI on exit : "
      DO I=1,N
         WRITE(*,"((E14.6,1X))") REAL(WI(I))
      ENDDO

      WRITE(*,*)'ILO : ',ILO
      WRITE(*,*)'IHI : ',IHI
      WRITE(*,*)'SCALE : ',SCALE
      WRITE(*,*)'ABNRM on exit :', ABNRM
      WRITE(*,*)'RCONDE on exit :', RCONDE
      WRITE(*,*)'RCONDV on exit :', RCONDV

      END PROGRAM LA_SGEEVX_EXAMPLE