!
! Copyright (c) 2020 TECHNICAL UNIVERSITY OF MUNICH, DEPARTMENT OF MECHANICAL ENGINEERING, CHAIR OF APPLIED MECHANICS,
! BOLTZMANNSTRASSE 15, 85748 GARCHING/MUNICH, GERMANY, RIXEN@TUM.DE.
!
! Distributed under 3-Clause BSD license. See LICENSE file for more information.
!

module material_fun
    use, intrinsic:: iso_fortran_env, only: dp=>real64
    use tools
    implicit none
    private

    public kirchhoff_sv_c_dc_3d, kirchhoff_sv_c_dc_2d, &
            mooney_rivlin_sv_c_dc_3d, mooney_rivlin_sv_c_dc_2d, &
            neo_hookean_sv_c_dc_3d, neo_hookean_sv_c_dc_2d

    contains

        subroutine kirchhoff_sv_c_dc_3d(f, df, t, s0, t0, s1, sv_out, c_out, dc_out, e_modul, nu, density, hypothesis)
            real(dp), intent(in) :: f(3,3)
            real(dp), intent(in) :: df(3,3)
            real(dp), intent(in) :: t
            real(dp), intent(in) :: s0(:)
            real(dp), intent(in) :: t0
            real(dp), intent(out) :: s1(:)
            real(dp), intent(out) :: sv_out(6)
            real(dp), intent(out) :: c_out(6,6)
            real(dp), intent(out) :: dc_out(6,6)
            real(dp), intent(in) :: e_modul
            real(dp), intent(in) :: nu
            real(dp), intent(in) :: density
            integer, intent(in) :: hypothesis

            real(dp) :: E(3,3)
            real(dp) :: lam, mu, Ev(6)

            lam = nu * e_modul / ((1.0_dp + nu) * (1.0_dp - 2*nu))
            mu  = e_modul / (2.0_dp*(1 + nu))

            C_out = reshape((/lam + 2*mu, lam, lam, 0.0_dp, 0.0_dp, 0.0_dp, &
                    lam, lam + 2*mu, lam, 0.0_dp, 0.0_dp, 0.0_dp, &
                    lam, lam, lam + 2*mu, 0.0_dp, 0.0_dp, 0.0_dp, &
                    0.0_dp, 0.0_dp, 0.0_dp, mu, 0.0_dp, 0.0_dp, &
                    0.0_dp, 0.0_dp, 0.0_dp, 0.0_dp, mu, 0.0_dp, &
                    0.0_dp, 0.0_dp, 0.0_dp, 0.0_dp, 0.0_dp, mu/), (/6,6/))

            call green_lagrange_strain_3d(f, Ev)

            Sv_out = matmul(C_out, Ev)
            dC_out = dC_out * 0.0_dp
        end subroutine kirchhoff_sv_c_dc_3d

        subroutine kirchhoff_sv_c_dc_2d(f, df, t, s0, t0, s1, sv_out, c_out, dc_out, e_modul, nu, density, &
                hypothesis)
            real(dp), intent(in) :: f(2,2)
            real(dp), intent(in) :: df(2,2)
            real(dp), intent(in) :: t
            real(dp), intent(in) :: s0(:)
            real(dp), intent(in) :: t0
            real(dp), intent(out) :: s1(:)
            real(dp), intent(out) :: sv_out(3)
            real(dp), intent(out) :: c_out(3,3)
            real(dp), intent(out) :: dc_out(3,3)
            real(dp), intent(in) :: e_modul
            real(dp), intent(in) :: nu
            real(dp), intent(in) :: density
            integer, intent(in) :: hypothesis

            real(dp) :: lam, mu, Ev(3)
            real(dp) :: E(2,2)

            lam = nu * E_modul / ((1.0_dp + nu) * (1.0_dp - 2*nu))
            mu  = E_modul / (2.0_dp*(1 + nu))

            !     This is slow, maybe one wants to change that in the future
            if (hypothesis == 2) then
                C_out = E_modul/(1.0_dp- nu**2)*reshape((/1.0_dp, nu, 0.0_dp, &
                        nu, 1.0_dp, 0.0_dp, &
                        0.0_dp, 0.0_dp, (1.0_dp-nu)/2.0_dp/), shape(C_out))
            elseif (hypothesis == 1) then
                C_out = reshape((/lam + 2*mu, lam, 0.0_dp, &
                        lam, lam + 2*mu, 0.0_dp, &
                        0.0_dp, 0.0_dp, mu/), shape(C_out))
            else
                stop 'f_kirchhoff_sv_c_dc may only be called for plane strain/stress (hypothesis = 1 or 2)'
            end if

            dC_out = dC_out * 0.0_dp
            call green_lagrange_strain_2d(F, Ev)
            Sv_out = matmul(C_out, Ev)

        end subroutine kirchhoff_sv_c_dc_2d

        subroutine mooney_rivlin_sv_c_dc_3d(f, df, t, s0, t0, s1, sv_out, c_out, dc_out, &
                a01, a10, kappa, hypothesis)
            real(dp), intent(in) :: f(3,3)
            real(dp), intent(in) :: df(3,3)
            real(dp), intent(in) :: t
            real(dp), intent(in) :: s0(:)
            real(dp), intent(in) :: t0
            real(dp), intent(out) :: s1(:)
            real(dp), intent(out) :: sv_out(6)
            real(dp), intent(out) :: c_out(6,6)
            real(dp), intent(out) :: dc_out(6,6)
            real(dp), intent(in) :: a01
            real(dp), intent(in) :: a10
            real(dp), intent(in) :: kappa
            integer, intent(in) :: hypothesis

            real(dp) :: C(3,3), I1E(6,1), I2E(6,1), I3E(6,1), I2EE(6,6), I3EE(6,6), &
                    J1E(6,1), J2E(6,1), J3E(6,1), EYE(3,3), J1EE(6,6), J2EE(6,6), J3EE(6,6)
            real(dp) :: C11, C22, C33, C23, C13, C12, I1, I2, I3, J3, &
                    J1I1, J1I3, J2I2, J2I3, J3I3, J1I1I3, J1I3I3, J2I2I3, J2I3I3, J3I3I3, E(3,3)

            if (hypothesis == 0) then
                EYE = reshape((/1.0_dp, 0.0_dp, 0.0_dp, 0.0_dp, 1.0_dp, 0.0_dp, 0.0_dp, 0.0_dp, 1.0_dp /), shape(EYE))
                C = matmul(transpose(F),F)

                E = F
                E = 0.5 * (matmul(transpose(F),F) - EYE)

                C11 = C(1,1)
                C22 = C(2,2)
                C33 = C(3,3)
                C23 = C(2,3)
                C13 = C(1,3)
                C12 = C(1,2)
                !   invariants and reduced invariants
                I1  = C11 + C22 + C33
                I2  = C11*C22 + C11*C33 - C12**2 - C13**2 + C22*C33 - C23**2
                I3  = C11*C22*C33 - C11*C23**2 - C12**2*C33 + 2*C12*C13*C23 - C13**2*C22

                J3  = sqrt(I3)
                !   derivatives
                J1I1 = I3**(-1.0_dp/3.0_dp)
                J1I3 = -I1/(3.0_dp*I3**(4.0_dp/3.00D0))
                J2I2 = I3**(-2.0_dp/3)
                J2I3 = -2.0_dp*I2/(3.0_dp*I3**(5.0_dp/3))
                J3I3 = 1./(2.0_dp*sqrt(I3))

                I1E = reshape((/2.0_dp, 2.0_dp, 2.0_dp, 0.0_dp, 0.0_dp, 0.0_dp/), shape(I1E))
                I2E = reshape((/2*C22 + 2*C33, 2*C11 + 2*C33, 2*C11 + 2*C22, -2*C23, -2*C13, -2*C12/), shape(I2E))
                I3E = reshape((/2*C22*C33 - 2*C23**2, 2*C11*C33 - 2*C13**2, 2*C11*C22 - 2*C12**2, &
                        -2*C11*C23 + 2*C12*C13, 2*C12*C23 - 2*C13*C22, -2*C12*C33 + 2*C13*C23/), shape(I3E))

                J1E = J1I1*I1E + J1I3*I3E
                J2E = J2I2*I2E + J2I3*I3E
                J3E = J3I3*I3E

                sv_out(:) = a10 * reshape(J1E, (/6/)) + a01 * reshape(J2E, (/6/)) + &
                        kappa*(J3 - 1)*reshape(J3E, (/6/))

                I2EE = reshape((/0.0_dp, 4.0_dp, 4.0_dp,  0.0_dp,  0.0_dp,  0.0_dp, &
                        4.0_dp, 0.0_dp, 4.0_dp,  0.0_dp,  0.0_dp,  0.0_dp, &
                        4.0_dp, 4.0_dp, 0.0_dp,  0.0_dp,  0.0_dp,  0.0_dp, &
                        0.0_dp, 0.0_dp, 0.0_dp, -2.0_dp,  0.0_dp,  0.0_dp, &
                        0.0_dp, 0.0_dp, 0.0_dp,  0.0_dp, -2.0_dp,  0.0_dp, &
                        0.0_dp, 0.0_dp, 0.0_dp,  0.0_dp,  0.0_dp, -2.0_dp/), shape(I2EE))

                I3EE = reshape((/    0.0_dp,  4.0_dp*C33,  4.0_dp*C22, -4.0_dp*C23,      0.0_dp,      0.0_dp, &
                        4.0_dp*C33,      0.0_dp,  4.0_dp*C11,      0.0_dp, -4.0_dp*C13,      0.0_dp, &
                        4.0_dp*C22,  4.0_dp*C11,      0.0_dp,      0.0_dp,      0.0_dp, -4.0_dp*C12, &
                        -4.0_dp*C23,      0.0_dp,      0.0_dp, -2.0_dp*C11,  2.0_dp*C12,  2.0_dp*C13, &
                        0.0_dp, -4.0_dp*C13,      0.0_dp,  2.0_dp*C12, -2.0_dp*C22,  2.0_dp*C23, &
                        0.0_dp,      0.0_dp, -4.0_dp*C12,  2.0_dp*C13,  2.0_dp*C23, -2.0_dp*C33/), shape(I3EE))

                !   second derivatives
                J1I1I3 = -1.0_dp/(3.0_dp*I3**(4.0_dp/3))
                J1I3I3 = 4*I1/(9*I3**(7.0_dp/3))
                J2I2I3 = -2.0_dp/(3*I3**(5.0_dp/3))
                J2I3I3 = 10*I2/(9*I3**(8.0_dp/3))
                J3I3I3 = -1.0_dp/(4*I3**(3.0_dp/2))

                J1EE = J1I1I3*(matmul(I1E, transpose(I3E)) + matmul(I3E, transpose(I1E))) &
                        + J1I3I3*matmul(I3E, transpose(I3E)) + J1I3*I3EE
                J2EE = J2I2I3*(matmul(I2E, transpose(I3E)) + matmul(I3E, transpose(I2E))) &
                        + J2I3I3*matmul(I3E, transpose(I3E)) + J2I2*I2EE + J2I3*I3EE
                J3EE = J3I3I3*(matmul(I3E, transpose(I3E))) + J3I3*I3EE

                c_out(:,:) = a10 * J1EE + a01*J2EE + kappa * (matmul(J3E, transpose(J3E))) + &
                        kappa *(J3-1.0)*J3EE
                dc_out(:,:) = 0.0_dp
            else
                stop 'mooney_rivlin_sv_c_dc_3d may only be called for tridimensional hypothesis (hypothesis = 0)'
            end if
        end subroutine mooney_rivlin_sv_c_dc_3d

        subroutine mooney_rivlin_sv_c_dc_2d(f, df, t, s0, t0, s1, sv_out, c_out, dc_out, a01, a10, kappa, &
                hypothesis)
            real(dp), intent(in) :: f(2,2)
            real(dp), intent(in) :: df(2,2)
            real(dp), intent(in) :: t
            real(dp), intent(in) :: s0(:)
            real(dp), intent(in) :: t0
            real(dp), intent(out) :: s1(:)
            real(dp), intent(out) :: sv_out(3)
            real(dp), intent(out) :: c_out(3,3)
            real(dp), intent(out) :: dc_out(3,3)
            real(dp), intent(in) :: a01
            real(dp), intent(in) :: a10
            real(dp), intent(in) :: kappa
            integer, intent(in) :: hypothesis

            stop 'mooney rivlin is not implemented for 2d'
        end subroutine mooney_rivlin_sv_c_dc_2d

        subroutine neo_hookean_sv_c_dc_3d(f, df, t, s0, t0, s1, sv_out, c_out, dc_out, &
                kappa, mu, hypothesis)
            real(dp), intent(in) :: f(3,3)
            real(dp), intent(in) :: df(3,3)
            real(dp), intent(in) :: t
            real(dp), intent(in) :: s0(:)
            real(dp), intent(in) :: t0
            real(dp), intent(out) :: s1(:)
            real(dp), intent(out) :: sv_out(6)
            real(dp), intent(out) :: c_out(6,6)
            real(dp), intent(out) :: dc_out(6,6)
            real(dp), intent(in) :: kappa
            real(dp), intent(in) :: mu
            integer, intent(in) :: hypothesis

            real(dp) :: C(3,3), I1E(6,1), I3E(6,1), I3EE(6,6), J1E(6,1), J3E(6,1), EYE(3,3), J1EE(6,6), J3EE(6,6), E(3,3)
            real(dp) :: C11, C22, C33, C23, C13, C12, I1, I3, J3, J1I1, J1I3, J3I3, J1I1I3, J1I3I3, J3I3I3

            if (hypothesis == 0) then
                EYE = reshape((/1.0_dp, 0.0_dp, 0.0_dp, 0.0_dp, 1.0_dp, 0.0_dp, 0.0_dp, 0.0_dp, 1.0_dp/), shape(EYE))
                C = matmul(transpose(F),F)

                E = 0.5_dp * (matmul(transpose(F),F) - EYE)

                C11 = C(1,1)
                C22 = C(2,2)
                C33 = C(3,3)
                C23 = C(2,3)
                C13 = C(1,3)
                C12 = C(1,2)
                !   invariants and reduced invariants
                I1  = C11 + C22 + C33
                I3  = C11*C22*C33 - C11*C23**2 - C12**2*C33 + 2*C12*C13*C23 - C13**2*C22

                J3  = sqrt(I3)
                !   derivatives
                J1I1 = I3**(-1.0/3.0_dp)
                J1I3 = -I1/(3*I3**(4.0_dp/3.0_dp))
                J3I3 = 1.0_dp/(2.0_dp*sqrt(I3))

                I1E = reshape((/2.0_dp, 2.0_dp, 2.0_dp, 0.0_dp, 0.0_dp, 0.0_dp/), shape(I1E))
                I3E = reshape((/2*C22*C33 - 2*C23**2, 2*C11*C33 - 2*C13**2, 2*C11*C22 - 2*C12**2, &
                        -2*C11*C23 + 2*C12*C13, 2*C12*C23 - 2*C13*C22, -2*C12*C33 + 2*C13*C23/), shape(I3E))

                J1E = J1I1*I1E + J1I3*I3E
                J3E = J3I3*I3E

                sv_out(:) = mu /2.*reshape(J1E, (/6/)) + kappa * (J3 - 1)*reshape(J3E, (/6/))

                I3EE = reshape((/    0.0_dp,  4.0_dp*C33,  4.0_dp*C22, -4.0_dp*C23,      0.0_dp,      0.0_dp, &
                        4.0_dp*C33,      0.0_dp,  4.0_dp*C11,      0.0_dp, -4.0_dp*C13,      0.0_dp, &
                        4.0_dp*C22,  4.0_dp*C11,      0.0_dp,      0.0_dp,      0.0_dp, -4.0_dp*C12, &
                        -4.0_dp*C23,      0.0_dp,      0.0_dp, -2.0_dp*C11,  2.0_dp*C12,  2.0_dp*C13, &
                        0.0_dp, -4.0_dp*C13,      0.0_dp,  2.0_dp*C12, -2.0_dp*C22,  2.0_dp*C23, &
                        0.0_dp,      0.0_dp, -4.0_dp*C12,  2.0_dp*C13,  2.0_dp*C23, -2.0_dp*C33/), shape(I3EE))

                !     second derivatives
                J1I1I3 = -1.0_dp/(3.0_dp*I3**(4.0_dp/3))
                J1I3I3 = 4*I1/(9*I3**(7.0_dp/3.0_dp))
                J3I3I3 = -1.0_dp/(4*I3**(3.0_dp/2.0_dp))

                J1EE = J1I1I3*(matmul(I1E, transpose(I3E)) + matmul(I3E, transpose(I1E))) &
                        + J1I3I3*matmul(I3E, transpose(I3E)) + J1I3*I3EE
                J3EE = J3I3I3*(matmul(I3E, transpose(I3E))) + J3I3*I3EE

                c_out(:,:) = mu /2*J1EE + kappa * (matmul(J3E, transpose(J3E))) + kappa * (J3-1.0_dp)*J3EE
                dc_out(:,:) = 0.0_dp
            else
                stop 'neo_hookean_sv_c_dc_3d is only allowed for tridimensional hypothesis (hypothesis = 0)'

            end if
        end subroutine neo_hookean_sv_c_dc_3d

        subroutine neo_hookean_sv_c_dc_2d(f, df, t, s0, t0, s1, sv_out, c_out, dc_out, kappa, mu, hypothesis)
            real(dp), intent(in) :: f(2,2)
            real(dp), intent(in) :: df(2,2)
            real(dp), intent(in) :: t
            real(dp), intent(in) :: s0(:)
            real(dp), intent(in) :: t0
            real(dp), intent(out) :: s1(:)
            real(dp), intent(out) :: sv_out(3)
            real(dp), intent(out) :: c_out(3,3)
            real(dp), intent(out) :: dc_out(3,3)
            real(dp), intent(in) :: kappa
            real(dp), intent(in) :: mu
            integer, intent(in) :: hypothesis

            real(dp) :: C(2,2), I1E(3,1), I3E(3,1), I3EE(3,3), J1E(3,1), J3E(3,1), EYE(2,2), J1EE(3,3), J3EE(3,3),E(2,2)
            real(dp) :: C11, C22, C33, C12, I1, I3, J3, J1I1, J1I3, J3I3, J1I1I3, J1I3I3, J3I3I3

            if (hypothesis == 1) then

                EYE = reshape((/1.0_dp, 0.0_dp, 0.0_dp, 1.0_dp/), shape(EYE))

                C = matmul(transpose(F),F)
                E = 0.5_dp * (C - EYE)

                C11 = C(1,1)
                C22 = C(2,2)
                C12 = C(1,2)
                C33 = 1.0_dp

                !   invariants and reduced invariants
                I1  = C11 + C22 + C33
                I3  = C11*C22 - C12**2
                J3  = sqrt(I3)

                !   derivatives
                J1I1 = I3**(-1.0/3.0_dp)
                J1I3 = -I1/(3*I3**(4.00D0/3.00D0))
                J3I3 = 1.0_dp/(2.0_dp*sqrt(I3))

                I1E = reshape((/2.0_dp, 2.0_dp, 0.0_dp /), shape(I1E))
                I3E = reshape((/2*C22*C33, 2*C11*C33, -2*C12*C33/), shape(I3E))

                J1E = J1I1*I1E + J1I3*I3E
                J3E = J3I3*I3E

                sv_out(:) = mu /2.0_dp*reshape(J1E, (/3/)) + kappa*(J3 - 1.0_dp)*reshape(J3E, (/3/))

                I3EE = reshape((/ 0.0_dp, 4.0_dp, 0.0_dp, &
                        4.0_dp, 0.0_dp, 0.0_dp, &
                        0.0_dp, 0.0_dp,-2.0_dp /), shape(I3EE))

                !   second derivatives
                J1I1I3 = -1.0_dp/(3.0_dp*I3**(4.0_dp/3))
                J1I3I3 = 4.0_dp*I1/(9.0_dp*I3**(7.0_dp/3))
                J3I3I3 = -1.0_dp/(4.0_dp*I3**(3.0_dp/2))

                J1EE = J1I1I3*(matmul(I1E, transpose(I3E)) + matmul(I3E, transpose(I1E))) &
                        + J1I3I3*matmul(I3E, transpose(I3E)) + J1I3*I3EE
                J3EE = J3I3I3*(matmul(I3E, transpose(I3E))) + J3I3*I3EE

                c_out(:,:) = mu /2.0_dp*J1EE + kappa * (matmul(J3E, transpose(J3E))) + kappa*(J3-1.0_dp)*J3EE
                dc_out(:,:) = 0.0_dp
            else
                stop 'neo_hookean_2d is only available for plane strain (hypothesis = 1)'
            end if

        end subroutine neo_hookean_sv_c_dc_2d

end module material_fun


module globals

  use iso_fortran_env, only: r64 => real64
  use slf_cgs

  implicit none !--------------------------------------------------------!

  character(len = *), parameter :: version = '210530'

  real(r64), parameter, private :: X0 = 0.68d0 / cgs_kapes_hydrogen - 1
  ! real(r64), parameter, private :: X0 = 0.7381
  real(r64), parameter, private :: Z0 = 0.0134

  real(r64) :: abuX = X0
  real(r64) :: abuZ = Z0

  real(r64) :: kappa_es = cgs_kapes_hydrogen * (1 + X0) / 2
  real(r64) :: kappa_ff_0 = 3.68d22 * (1 - Z0) * (1 + X0)
  real(r64) :: kappa_bf_0 = 4.34d25 * Z0 * (1 + X0)
  real(r64) :: kappa_abs_0 = 3.68d22 * (1 - Z0) * (1 + X0)
  real(r64) :: opacities_kill = 1

  logical :: use_klein_nishina = .false.
  logical :: use_opacity_ff = .true.
  logical :: use_opacity_bf = .true.
  logical :: use_conduction = .false.
  logical :: use_relcompt = .true.

  real(r64) :: mbh, mdot, rschw
  real(r64), parameter :: accretion_efficiency = 0.083_r64
  real(r64), parameter :: radius_isco = 3

  real(r64) :: cndredu = 1

  real(r64), parameter :: miu = 0.5_r64
  real(r64), parameter :: pi = 4*atan(real(1,r64))

  !   którego równania użyc?
  character, parameter :: EQUATION_DIFFUSION = 'D', &
  EQUATION_BALANCE = 'C', EQUATION_COMPTON = 'W'
  character :: cfg_temperature_method = EQUATION_DIFFUSION

contains !-----------------------------------------------------------------!

  elemental function mdot_edd(mbh)
    real(r64), intent(in) :: mbh
    real(r64) :: mdot_edd, GM

    GM = cgs_graw * (mbh * sol_mass)
    mdot_edd = 4 * pi * GM / (cgs_c * cgs_kapes * accretion_efficiency)
  end function

  elemental subroutine cylinder(mbh, mdot, r, rschw, omega, facc, teff, zscale)
    real(r64), intent(in) :: mbh, mdot, r
    real(r64), intent(out) :: rschw, omega, facc, teff, zscale
    real(r64) :: GM

    GM = cgs_graw * (mbh * sol_mass)

    rschw = 2 * GM / cgs_c**2
    omega = sqrt( GM / (r * rschw)**3 )

    facc = 3 * GM * (mdot * mdot_edd(mbh)) / (8 * pi * (r * rschw)**3) &
    &    * (1 - sqrt(radius_isco / r))

    teff = (facc / cgs_stef)**0.25_r64
    zscale = sqrt( 2 * cgs_k_over_mh * teff ) / omega
  end subroutine

  elemental function fzscale(mbh, mdot, r) result(zscale)
    real(r64), intent(in) :: mbh, mdot, r
    real(r64) :: omega, facc, teff, zscale, rschw
    call cylinder(mbh, mdot, r, rschw, omega, facc, teff, zscale)
  end function

  elemental function fzscale_rad(mbh, mdot, r) result(zscale)
    real(r64), intent(in) :: mbh, mdot, r
    real(r64) :: omega, facc, teff, zscale, rschw
    call cylinder(mbh, mdot, r, rschw, omega, facc, teff, zscale)
    zscale = cgs_kapes * facc / (omega**2 * cgs_c)
  end function

  elemental function fTeff(mbh, mdot, r) result(teff)
    real(r64), intent(in) :: mbh, mdot, r
    real(r64) :: omega, facc, teff, zscale, rschw
    call cylinder(mbh, mdot, r, rschw, omega, facc, teff, zscale)
  end function

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

  elemental function kff0(X, Z)
    real(r64), intent(in) :: X, Z
    real(r64) :: kff0
    kff0 = 3.68e22_r64 * (1 - Z) * (1 + X)
  end function

  elemental function kbf0(X, Z)
    real(r64), intent(in) :: X, Z
    real(r64) :: kbf0
    kbf0 = 4.34e25_r64 * Z * (1 + X)
  end function

  elemental function kram0(X, Z) result(kab0)
    real(r64), intent(in) :: X, Z
    real(r64) :: kab0
    kab0 = merge(kff0(X, Z), 0.0_r64, use_opacity_ff)   &
         + merge(kbf0(X, Z), 0.0_r64, use_opacity_bf)
  end function

  elemental function kram0p(X, Z) result(kab0)
    real(r64), intent(in) :: X, Z
    real(r64) :: kab0
    ! for energy balance we use only free-free
    kab0 = merge(kff0(X, Z) * 37.0_r64, 0.0_r64, use_opacity_ff)
  end function

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

  elemental function fkesp(rho,T) result(ksct)
    real(r64), intent(in) :: rho,T
    real(r64):: ksct

    associate (ksct0 => cgs_kapes_hydrogen * (1 + abuX) / 2, &
        kill => opacities_kill)
      if (use_klein_nishina) then
        ksct = ksct0 / ((1 + 2.7d+11*kill*rho/T**2)*(3.6161d-8*T**0.86d0*kill + 1))
      else
        ksct = ksct0
      end if
    end associate
  end function

  elemental subroutine kappesp(rho, T, ksct, krho, ktemp)
    real(r64), intent(in) :: rho, T
    real(r64), intent(out) :: ksct, krho, ktemp

    associate (ksct0 => cgs_kapes_hydrogen * (1 + abuX) / 2, &
        kill => opacities_kill)
      if (use_klein_nishina) then
        ksct = ksct0 / ((1 + 2.7d+11*kill*rho/T**2)*(3.6161d-8*T**0.86d0*kill + 1))
        krho = -2.7d+11*kill*ksct0/(T**2*(1.0d0 + 2.7d+11*kill*rho/T**2)**2*( &
              3.6161d-8*T**0.86d0*kill + 1.0d0))
        ktemp = -3.1098d-8*T**(-0.14d0)*kill*ksct0/((1.0d0 + 2.7d+11*kill*rho/T &
              **2)*(3.6161d-8*T**0.86d0*kill + 1.0d0)**2) + 5.4d+11*kill*ksct0* &
              rho/(T**3*(1.0d0 + 2.7d+11*kill*rho/T**2)**2*(3.6161d-8*T**0.86d0 &
              *kill + 1.0d0))
      else
        ksct = ksct0
        krho = 0
        ktemp = 0
      end if
    end associate
  end subroutine

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

  elemental function fkabs(rho,T) result(kap)
    real(r64), intent(in) :: rho,T
    real(r64) :: kap

    associate (kbff0 => kram0(abuX,abuZ), kill => opacities_kill)
      kap = fkesp(rho, T) + kill * kbff0 * rho * T**(-3.5_r64)
    end associate
  end function

  elemental subroutine kappabs(rho,T,kap,krho,ktemp)
    use ieee_arithmetic, only: ieee_is_nan
    real(r64), intent(in) :: rho,T
    real(r64), intent(out) :: kap,krho,ktemp
    real(r64) :: kes, kes_rho, kes_temp

    call kappesp(rho, T, kes, kes_rho, kes_temp)

    associate (kbff0 => kram0(abuX,abuZ), kill => opacities_kill)
      kap = kes + kill * kbff0 * rho * T**(-3.5_r64)
      krho = kes_rho + kill * kbff0 * T**(-3.5_r64)
      ktemp = kes_temp - 3.5_r64 * kill * kbff0 * rho * T**(-4.5_r64)
    end associate
  end subroutine

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

  elemental function fkabp(rho,T) result(kap)
    real(r64), intent(in) :: rho,T
    real(r64) :: kap

    associate (kbff0 => kram0p(abuX,abuZ))
      kap = kbff0 * rho * T**(-3.5_r64)
    end associate
  end function

  elemental subroutine kappabp(rho,T,kap,krho,ktemp)
    use ieee_arithmetic, only: ieee_is_nan
    real(r64), intent(in) :: rho,T
    real(r64), intent(out) :: kap,krho,ktemp

    associate (kbff0 => kram0p(abuX,abuZ))
      kap = kbff0 * rho * T**(-3.5_r64)
      krho = kbff0 * T**(-3.5_r64)
      ktemp = - 3.5_r64 * kbff0 * rho * T**(-4.5_r64)
    end associate
  end subroutine

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

  elemental function fkcnd(rho,T) result(kcnd)
    real(r64), intent(in) :: rho,T
    real(r64) :: kcnd
    kcnd = 5.6d-7 * cndredu * T**2.5d0
  end function

  elemental subroutine kappcnd(rho,T,kap,krho,kT)
    use ieee_arithmetic, only: ieee_is_nan
    real(r64), intent(in) :: rho,T
    real(r64), intent(out) :: kap,krho,kT

    kap = 5.6d-7 * cndredu * T**2.5d0
    krho = 0
    kT = 2.5d0 * kap / T
  end subroutine

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

  elemental function rho_crit(Trad, T) result(rho)
    real(r64), intent(in) :: Trad
    real(r64), intent(in), optional :: T
    real(r64) :: rho

    rho = cgs_kapes / kram0p(abuX, abuZ) &
          * 4 * cgs_k_over_mec2 * Trad**4.5
    if (present(T)) then
      rho = rho * sqrt(Trad / T)
    end if
  end function

end module


program bwtest1
  use flips

  implicit none

  type(flips_s) :: h,h2

  real(sp), dimension(100,100) :: a
  real(sp), dimension(100) :: sol, meas , fs1
  real(sp), dimension(101) :: row
  real(sp), dimension(11) :: ww
  real(sp), dimension(101) :: fs2
  logical, dimension(100) :: rmask

  integer :: i

  do i = 1,100
     sol(i) = real(i,8)
  end do

  a = 0.0
  do i = 1,90
     call random_number(ww)
     a(i,i:i+10) = ww
  end do

  do i = 1,100
     a(i,i) = 1.0
  end do

  meas = matmul(a,sol)

  call flips_init(h,100,1,bandwidth=1,buffersize=10)

  do i = 1,100
     call flips_add(h,1,a(i,:),meas(i))
  end do

  call flips_solve(h)

  fs1 = h%solmat

  rmask=.FALSE.
  rmask(41:60) = .TRUE.

  call flips_resize(h2,h,remove=rmask,newsize=101)

  write(*,*) 'h2cols=',h2%ncols

  do i = 1,21
     row = 0.0
     row(80+i) = 2.0
     if (i == 1) write(*,*) row
     call flips_add(h2,1,row,1.0)
  end do

  call make_rotations_s(h2)

  write(*,*) h2%ymat

  !write(*,*) h2%rmat(rind(101,101,101,h2%bw))

  call flips_solve(h2)

  fs2 = h2%solmat

  write(*,*) fs1

  write(*,*) '***********************************************************'

  write(*,*) fs2

  write(*,*) '***********************************************************'

  write(*,*) h2%bw,h%bw

  call flips_kill(h)
  call flips_kill(h2)

end program bwtest1


      subroutine annulus46_setaux(mbc,mx,my,
     &      xlower,ylower,dx,dy,maux,aux,blockno,
     &      area, xd,yd,zd, edgelengths,xnormals,ynormals,
     &      xtangents, ytangents, surfnormals)
      implicit none

      integer mbc, mx,my, meqn, maux
      integer blockno
      double precision dx,dy, xlower, ylower
      double precision aux(1-mbc:mx+mbc,1-mbc:my+mbc, maux)

      integer i,j, k
      double precision dxdy,t

      include "metric_terms.i"

c     # ----------------------------------------------------------------
c     # Conservative form (cell-centered velocities)
c     # 1       Capacity
c     # 2-3     Cell-centered velocities
c     # 4-11    Normals at all four faces
c     # 12-15   Edge lengths
c     # ----------------------------------------------------------------

      dxdy = dx*dy

c     # Capacity : entry (1)
      do i = 1-mbc,mx+mbc
         do j = 1-mbc,my+mbc
            aux(i,j,1) = area(i,j)/dxdy
         enddo
      enddo

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

c     # Needed to scale speeds in Riemann solver when using
c     # cell-centered velocities
      do i = 1-mbc,mx+mbc
          do j = 1-mbc,my+mbc
c             # x-face and y-face edge lengths (6,7)
              aux(i,j,12) = edgelengths(i,j,1)/dy
              aux(i,j,13) = edgelengths(i+1,j,1)/dy
              aux(i,j,14) = edgelengths(i,j,2)/dx
              aux(i,j,15) = edgelengths(i,j+1,2)/dx
          end do
      end do

      return
      end

      subroutine annulus46_set_center_velocities(mx,my,mbc,
     &          dx,dy,blockno,xlower,ylower,t,
     &          edgelengths,xnormals,ynormals,
     &          xtangents, ytangents, surfnormals,
     &          aux, maux)
      implicit none

      integer mx,my,mbc,maux,blockno
      double precision dx,dy, xlower,ylower, t
      double precision aux(1-mbc:mx+mbc,1-mbc:my+mbc,maux)

      double precision xc,yc,xc1,yc1,zc1, x,y
      double precision nv(3), vel(3)

      double precision nl(3), nr(3), nb(3), nt(3)

      integer*8 cont, get_context

      integer i,j, k
      double precision wl(3), wb(3)

      include "metric_terms.i"

      cont = get_context()

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

c           # This is not the annulus mapping, but rather maps
c           # the brick to a unit square
            call fclaw2d_map_brick2c(cont,blockno,xc,yc,xc1,yc1,zc1)

            call annulus_center_velocity(xc1,yc1,t,vel)

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

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

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

      end

      subroutine setaux_cross(u,v,w)
      implicit none

      double precision u(3), v(3), w(3)

      w(1) =  u(2)*v(3) - u(3)*v(2)
      w(2) = -u(1)*v(3) + u(3)*v(1)
      w(3) =  u(1)*v(2) - u(2)*v(1)

      end


!	Print reliability results for observed scores.
!	comment is used to identify output.
!	factorname is variable names.
!	unitobsrel is unit.
!	covobs is the covariance matrix of the observations vector.
!	covres is the covariance matrix of the residuals.
!   obsave is the average of the scores.
!	rel contains reliabilities.

subroutine obsreloutput(comment,factorname,unitobsrel,&
    covobs,covres,obsave,rel)
implicit none
interface

!	write a label and a floating point number x in csv format to unit.
	subroutine writelabelfl(label,unit,x)
		implicit none
		character(len=*),intent(in)::label
		integer,intent(in)::unit
		real(kind=8),intent(in)::x
	end subroutine writelabelfl
!	print square matrix.
!	method is the type of matrix.
!	rowname provides row names.
!	unitmat is the unit number to use.
!	mat provides the matrix.
	subroutine matoutput(comment,rowname,unitmat,mat)
		implicit none
		character(len=*),intent(in)::comment
		character(len=*),intent(in)::rowname(:)
		integer,intent(in)::unitmat
		real(kind=8),intent(in)::mat(:,:)
	end subroutine matoutput
end interface
character(len=*),intent(in)::comment
character(len=32),intent(in)::factorname(:)
integer,intent(in)::unitobsrel
real(kind=8),intent(in)::covobs(:,:),covres(:,:),obsave(:),rel(:)

!	Count rows.
integer::row
write(unitobsrel,'(2a)') "Reliability analysis ",comment
write(unitobsrel,'(a)') "Averages of scores"
do row=1,size(rel)
	call writelabelfl(factorname(row),unitobsrel,obsave(row))

end do

call matoutput("Covariance matrix of scores",factorname,unitobsrel,covobs)
call matoutput("Covariance matrix of residuals",factorname,unitobsrel,covres)

write(unitobsrel,'(a)') "Reliabilities of observed scores"
do row=1,size(rel)
	call writelabelfl(factorname(row),unitobsrel,rel(row))
end do

return

end subroutine obsreloutput


        subroutine idz_matadj(m,n,a,aa)
c
c       Takes the adjoint of a to obtain aa.
c
c       input:
c       m -- first dimension of a, and second dimension of aa
c       n -- second dimension of a, and first dimension of aa
c       a -- matrix whose adjoint is to be taken
c
c       output:
c       aa -- adjoint of a
c
        implicit none
        integer m,n,j,k
        complex*16 a(m,n),aa(n,m)
c
c
        do k = 1,n
          do j = 1,m
            aa(k,j) = conjg(a(j,k))
          enddo ! j
        enddo ! k
c
c
        return
        end
c
c
c
c
        subroutine idz_matmulta(l,m,a,n,b,c)
c
c       multiplies a and b^* to obtain c.
c
c       input:
c       l -- first dimension of a and c
c       m -- second dimension of a and b
c       a -- leftmost matrix in the product c = a b^*
c       n -- first dimension of b and second dimension of c
c       b -- rightmost matrix in the product c = a b^*
c
c       output:
c       c -- product of a and b^*
c
        implicit none
        integer l,m,n,i,j,k
        complex*16 a(l,m),b(n,m),c(l,n),sum
c
c
        do i = 1,l
          do k = 1,n
c
            sum = 0
c
            do j = 1,m
              sum = sum+a(i,j)*conjg(b(k,j))
            enddo ! j
c
            c(i,k) = sum
c
          enddo ! k
        enddo ! i
c
c
        return
        end
c
c
c
c
        subroutine idz_rearr(krank,ind,m,n,a)
c
c       rearranges a according to ind obtained
c       from routines idzr_qrpiv or idzp_qrpiv,
c       assuming that a = q r, where q and r are from idzr_qrpiv
c       or idzp_qrpiv.
c
c       input:
c       krank -- rank obtained from routine idzp_qrpiv,
c                or provided to routine idzr_qrpiv
c       ind -- indexing array obtained from routine idzr_qrpiv
c              or idzp_qrpiv
c       m -- first dimension of a
c       n -- second dimension of a
c       a -- matrix to be rearranged
c
c       output:
c       a -- rearranged matrix
c
        implicit none
        integer k,krank,m,n,j,ind(krank)
        complex*16 cswap,a(m,n)
c
c
        do k = krank,1,-1
          do j = 1,m
c
            cswap = a(j,k)
            a(j,k) = a(j,ind(k))
            a(j,ind(k)) = cswap
c
          enddo ! j
        enddo ! k
c
c
        return
        end
c
c
c
c
        subroutine idz_rinqr(m,n,a,krank,r)
c
c       extracts R in the QR decomposition specified by the output a
c       of the routine idzr_qrpiv or idzp_qrpiv.
c
c       input:
c       m -- first dimension of a
c       n -- second dimension of a and r
c       a -- output of routine idzr_qrpiv or idzp_qrpiv
c       krank -- rank output by routine idzp_qrpiv (or specified
c                to routine idzr_qrpiv)
c
c       output:
c       r -- triangular factor in the QR decomposition specified
c            by the output a of the routine idzr_qrpiv or idzp_qrpiv
c
        implicit none
        integer m,n,j,k,krank
        complex*16 a(m,n),r(krank,n)
c
c
c       Copy a into r and zero out the appropriate
c       Householder vectors that are stored in one triangle of a.
c
        do k = 1,n
          do j = 1,krank
            r(j,k) = a(j,k)
          enddo ! j
        enddo ! k
c
        do k = 1,n
          if(k .lt. krank) then
            do j = k+1,krank
              r(j,k) = 0
            enddo ! j
          endif
        enddo ! k
c
c
        return
        end


program test_convert_ub_and_bv
  use mod_orrb
  implicit none

  !
  ! Note: This does not cover large rank cases (e.g. ubw=n-1).
  !
  character(len=40) :: test_name
  character(len=*), parameter :: fmt="(A40, 'Time: ',ES8.2,', ubw: ',I3,', error: ',ES8.2, ', ', A10)"

  real(kind=dp) :: t0, t1
  integer(kind=int32) :: na, lbwa, ubwa
  type(error_info) :: error
  real(kind=dp), parameter :: tol=1e-15, c=2.0
  !
  real(kind=dp), dimension(:,:), allocatable :: a0_d, a1_d
  complex(kind=dp), dimension(:,:), allocatable :: a0_z, a1_z

  type(d_ub), allocatable :: ub_d
  type(z_ub), allocatable :: ub_z
  type(d_bv), allocatable :: bv_d
  type(z_bv), allocatable :: bv_z

  call initialize_errors

  print *
  print *, "--------------------------------"
  print *
  print *, "Real UB and BV Conversion Tests:"
  print *
  na=40
  lbwa=3; ubwa=5
  ub_d=d_random_ub(na,lbwa,ubwa,error=error)
  a0_d=general(ub_d,error)
  call cpu_time(t0)
  bv_d=bv_of(ub_d,error)
  call cpu_time(t1)
  a1_d=general(bv_d,error)
  test_name = "Real UB to BV, n=40;"
  call d_output_result(test_name,a0_d,a1_d,ubwa,bv_d%ubw,t0,t1,c*tol,error)

  na=1
  lbwa=0; ubwa=0
  ub_d=d_random_ub(na,lbwa,ubwa,error=error)
  a0_d=general(ub_d,error)
  call cpu_time(t0)
  bv_d=bv_of(ub_d,error)
  call cpu_time(t1)
  a1_d=general(bv_d,error)
  test_name = "Real UB to BV, n=1;"
  call d_output_result(test_name,a0_d,a1_d,ubwa,bv_d%ubw,t0,t1,c*tol,error)

  na=2
  lbwa=1; ubwa=1
  ub_d=d_random_ub(na,lbwa,ubwa,error=error)
  a0_d=general(ub_d,error)
  call cpu_time(t0)
  bv_d=bv_of(ub_d,error)
  call cpu_time(t1)
  a1_d=general(bv_d,error)
  test_name = "Real UB to BV, n=2;"
  call d_output_result(test_name,a0_d,a1_d,ubwa,bv_d%ubw,t0,t1,c*tol,error)

  na=3
  lbwa=1; ubwa=1
  ub_d=d_random_ub(na,lbwa,ubwa,error=error)
  a0_d=general(ub_d,error)
  call cpu_time(t0)
  bv_d=bv_of(ub_d,error)
  call cpu_time(t1)
  a1_d=general(bv_d,error)
  test_name = "Real UB to BV, n=3;"
  call d_output_result(test_name,a0_d,a1_d,ubwa,bv_d%ubw,t0,t1,c*tol,error)

  na=4
  lbwa=2; ubwa=2
  ub_d=d_random_ub(na,lbwa,ubwa,error=error)
  a0_d=general(ub_d,error)
  call cpu_time(t0)
  bv_d=bv_of(ub_d,error)
  call cpu_time(t1)
  a1_d=general(bv_d,error)
  test_name = "Real UB to BV, n=4;"
  call d_output_result(test_name,a0_d,a1_d,ubwa,bv_d%ubw,t0,t1,c*tol,error)
  print *

  na=40
  lbwa=3; ubwa=5
  bv_d=d_random_bv(na,lbwa,ubwa,error=error)
  a0_d=general(bv_d,error)
  call cpu_time(t0)
  ub_d=ub_of(bv_d,error)
  call cpu_time(t1)
  a1_d=general(ub_d,error)
  test_name = "Real BV to UB, n=40;"
  call d_output_result(test_name,a0_d,a1_d,ubwa,ub_d%ubw,t0,t1,c*tol,error)

  na=1
  lbwa=0; ubwa=0
  bv_d=d_random_bv(na,lbwa,ubwa,error=error)
  a0_d=general(bv_d,error)
  call cpu_time(t0)
  ub_d=ub_of(bv_d,error)
  call cpu_time(t1)
  a1_d=general(ub_d,error)
  test_name = "Real BV to UB, n=1;"
  call d_output_result(test_name,a0_d,a1_d,ubwa,ub_d%ubw,t0,t1,c*tol,error)

  na=2
  lbwa=1; ubwa=1
  bv_d=d_random_bv(na,lbwa,ubwa,error=error)
  a0_d=general(bv_d,error)
  call cpu_time(t0)
  ub_d=ub_of(bv_d,error)
  call cpu_time(t1)
  a1_d=general(ub_d,error)
  test_name = "Real BV to UB, n=2;"
  call d_output_result(test_name,a0_d,a1_d,ubwa,ub_d%ubw,t0,t1,c*tol,error)

  na=3
  lbwa=1; ubwa=1
  bv_d=d_random_bv(na,lbwa,ubwa,error=error)
  a0_d=general(bv_d,error)
  call cpu_time(t0)
  ub_d=ub_of(bv_d,error)
  call cpu_time(t1)
  a1_d=general(ub_d,error)
  test_name = "Real BV to UB, n=3;"
  call d_output_result(test_name,a0_d,a1_d,ubwa,ub_d%ubw,t0,t1,c*tol,error)

  na=4
  lbwa=2; ubwa=2
  bv_d=d_random_bv(na,lbwa,ubwa,error=error)
  a0_d=general(bv_d,error)
  call cpu_time(t0)
  ub_d=ub_of(bv_d,error)
  call cpu_time(t1)
  a1_d=general(ub_d,error)
  test_name = "Real BV to UB, n=4;"
  call d_output_result(test_name,a0_d,a1_d,ubwa,ub_d%ubw,t0,t1,c*tol,error)

  print *
  print *, "--------------------------------"
  print *
  print *, "Complex UB and BV Conversion Tests:"
  print *

  na=40
  lbwa=3; ubwa=5
  ub_z=z_random_ub(na,lbwa,ubwa,error=error)
  a0_z=general(ub_z,error)
  call cpu_time(t0)
  bv_z=bv_of(ub_z,error)
  call cpu_time(t1)
  a1_z=general(bv_z,error)
  test_name = "Complex UB to BV, n=40;"
  call z_output_result(test_name,a0_z,a1_z,ubwa,bv_z%ubw,t0,t1,c*tol,error)

  na=1
  lbwa=0; ubwa=0
  ub_z=z_random_ub(na,lbwa,ubwa,error=error)
  a0_z=general(ub_z,error)
  call cpu_time(t0)
  bv_z=bv_of(ub_z,error)
  call cpu_time(t1)
  a1_z=general(bv_z,error)
  test_name = "Complex UB to BV, n=1;"
  call z_output_result(test_name,a0_z,a1_z,ubwa,bv_z%ubw,t0,t1,c*tol,error)

  na=2
  lbwa=1; ubwa=1
  ub_z=z_random_ub(na,lbwa,ubwa,error=error)
  a0_z=general(ub_z,error)
  call cpu_time(t0)
  bv_z=bv_of(ub_z,error)
  call cpu_time(t1)
  a1_z=general(bv_z,error)
  test_name = "Complex UB to BV, n=2;"
  call z_output_result(test_name,a0_z,a1_z,ubwa,bv_z%ubw,t0,t1,c*tol,error)

  na=3
  lbwa=1; ubwa=1
  ub_z=z_random_ub(na,lbwa,ubwa,error=error)
  a0_z=general(ub_z,error)
  call cpu_time(t0)
  bv_z=bv_of(ub_z,error)
  call cpu_time(t1)
  a1_z=general(bv_z,error)
  test_name = "Complex UB to BV, n=3;"
  call z_output_result(test_name,a0_z,a1_z,ubwa,bv_z%ubw,t0,t1,c*tol,error)

  na=4
  lbwa=2; ubwa=2
  ub_z=z_random_ub(na,lbwa,ubwa,error=error)
  a0_z=general(ub_z,error)
  call cpu_time(t0)
  bv_z=bv_of(ub_z,error)
  call cpu_time(t1)
  a1_z=general(bv_z,error)
  test_name = "Complex UB to BV, n=4;"
  call z_output_result(test_name,a0_z,a1_z,ubwa,bv_z%ubw,t0,t1,c*tol,error)
  print *

  na=40
  lbwa=3; ubwa=5
  bv_z=z_random_bv(na,lbwa,ubwa,error=error)
  a0_z=general(bv_z,error)
  call cpu_time(t0)
  ub_z=ub_of(bv_z,error)
  call cpu_time(t1)
  a1_z=general(ub_z,error)
  test_name = "Complex BV to UB, n=40;"
  call z_output_result(test_name,a0_z,a1_z,ubwa,ub_z%ubw,t0,t1,c*tol,error)

  na=1
  lbwa=0; ubwa=0
  bv_z=z_random_bv(na,lbwa,ubwa,error=error)
  a0_z=general(bv_z,error)
  call cpu_time(t0)
  ub_z=ub_of(bv_z,error)
  call cpu_time(t1)
  a1_z=general(ub_z,error)
  test_name = "Complex BV to UB, n=1;"
  call z_output_result(test_name,a0_z,a1_z,ubwa,ub_z%ubw,t0,t1,c*tol,error)

  na=2
  lbwa=1; ubwa=1
  bv_z=z_random_bv(na,lbwa,ubwa,error=error)
  a0_z=general(bv_z,error)
  call cpu_time(t0)
  ub_z=ub_of(bv_z,error)
  call cpu_time(t1)
  a1_z=general(ub_z,error)
  test_name = "Complex BV to UB, n=2;"
  call z_output_result(test_name,a0_z,a1_z,ubwa,ub_z%ubw,t0,t1,c*tol,error)

  na=3
  lbwa=1; ubwa=1
  bv_z=z_random_bv(na,lbwa,ubwa,error=error)
  a0_z=general(bv_z,error)
  call cpu_time(t0)
  ub_z=ub_of(bv_z,error)
  call cpu_time(t1)
  a1_z=general(ub_z,error)
  test_name = "Complex BV to UB, n=3;"
  call z_output_result(test_name,a0_z,a1_z,ubwa,ub_z%ubw,t0,t1,c*tol,error)

  na=4
  lbwa=2; ubwa=2
  bv_z=z_random_bv(na,lbwa,ubwa,error=error)
  a0_z=general(bv_z,error)
  call cpu_time(t0)
  ub_z=ub_of(bv_z,error)
  call cpu_time(t1)
  a1_z=general(ub_z,error)
  test_name = "Complex BV to UB, n=4;"
  call z_output_result(test_name,a0_z,a1_z,ubwa,ub_z%ubw,t0,t1,c*tol,error)

contains

  subroutine d_output_result(name,a0,a1,ubw0,ubw1,t0,t1,bnd,error)
    character(len=*) :: name
    real(kind=dp), dimension(:,:) :: a0, a1
    real(kind=dp) :: bnd, t0, t1
    integer(kind=int32) :: ubw0, ubw1
    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 (ubw0==ubw1 .and. berr < bnd) then
          test_result="PASSED"
       else
          test_result="    FAILED"
       end if
       write (*,fmt) name, t1-t0, ubw1, berr, test_result
    end if
  end subroutine d_output_result

  subroutine z_output_result(name,a0,a1,ubw0,ubw1,t0,t1,bnd,error)
    character(len=*) :: name
    complex(kind=dp), dimension(:,:) :: a0, a1
    real(kind=dp) :: bnd, t0, t1
    integer(kind=int32) :: ubw0, ubw1
    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 (ubw0==ubw1 .and. berr < bnd) then
          test_result="PASSED"
       else
          test_result="    FAILED"
       end if
       write (*,fmt) name, t1-t0, ubw1, berr, test_result
    end if
  end subroutine z_output_result

end program test_convert_ub_and_bv


submodule(euler_interface_m) euler_prob_0042_m
    implicit none

contains

    module character(len=20) function euler0042()
        write (euler0042, "(i20)") answer()
    end function euler0042

    integer function answer()
        use euler_data_m, only: get_euler_data_0042
        implicit none

        integer :: i, j
        integer, parameter :: max_score = 26*20
        logical :: is_tri_num(max_score)
        character(len=:), allocatable :: names(:)

        call tri_num(max_score, is_tri_num)
        call get_euler_data_0042(names)

        j = 0

        do i = 1, size(names)
            if (is_tri_num(score_of_word(names(i)))) then
                j = j + 1
            end if
        end do

        answer = j
    end function answer

    integer function score_of_word(str)
        character(len=*), intent(in) :: str
        integer :: j, isum

        isum = 0

        do j = 1, len_trim(str)
            isum = isum + iachar(str(j:j)) - 64
        end do

        score_of_word = isum
    end function score_of_word

    subroutine tri_num(n, is_tri_num)
        integer, intent(in) :: n
        logical, intent(out) :: is_tri_num(n)
        integer :: i

        is_tri_num = .false.

        i = 1
        do while (i*(i + 1)/2 <= n)
            is_tri_num(i*(i + 1)/2) = .true.
            i = i + 1
        end do
    end subroutine tri_num
end submodule euler_prob_0042_m


! Test IO of arrays of integers in derived types
! { dg-do run }
! { dg-options "-std=legacy" }
!
program main

  character* 10000 :: buf1, buf2
  type xyz
     integer :: x, y(3), z
  end type xyz

  type (xyz) :: foo(4)

  do i=1,ubound(foo,1)
     foo(i)%x = 100*i
     do j=1,3
        foo(i)%y(j) = 100*i + 10*j
     enddo
     foo(i)%z = 100*i+40
  enddo

  write (buf1, '(20i4)')  foo
  write (buf2, '(20i4)')  (foo(i)%x, (foo(i)%y(j), j=1,3), foo(i)%z, i=1,4)

  if (buf1.ne.buf2) call abort
end program main


program test_hfmm3d_mp2loc
  implicit double precision (a-h,o-z)

  character(len=72) str1

  integer :: ns, nt, nc
  integer :: i,j,k,ntest,nd,idim
  integer :: ifcharge,ifdipole,ifpgh,ifpghtarg
  integer :: ipass(18),len1,ntests,isum
  integer, allocatable :: nterms(:), impole(:)

  double precision :: eps, err, hkrand, dnorms(1000), force(10)
  double precision, allocatable :: source(:,:), targ(:,:)
  double precision, allocatable :: centers(:,:)
  double precision, allocatable :: wlege(:), rscales(:)

  double complex :: eye, zk, ima
  double complex, allocatable :: charge(:,:)
  double complex, allocatable :: dipvec(:,:,:)
  double complex, allocatable :: pot(:,:), pot2(:,:), pottarg(:,:)
  double complex, allocatable :: grad(:,:,:),gradtarg(:,:,:)
  double complex, allocatable :: hess(:,:,:),hesstarg(:,:,:)
  double complex, allocatable :: mpole(:), local(:)

  data eye/(0.0d0,1.0d0)/
  ima = (0,1)
  done = 1
  pi = 4*atan(done)

  !
  ! initialize printing routine
  !
  call prini(6,13)

  nd = 3

  n1 = 3
  ns = n1**3
  nc = ns

  call prinf('ns = *', ns, 1)
  call prinf('nc = *', nc, 1)

  nt = 19

  allocate(source(3,ns),targ(3,nt), centers(3,nc))
  allocate(charge(nd,ns),dipvec(nd,3,ns))
  allocate(pot(nd,ns), pot2(nd,ns))
  allocate(grad(nd,3,ns))
  allocate(hess(nd,6,ns))

  allocate(pottarg(nd,nt))
  allocate(gradtarg(nd,3,nt))
  allocate(hesstarg(nd,6,nt))
  eps = 0.5d-9

  write(*,*) "=========================================="
  write(*,*) "Testing suite for hfmm3d_mps"
  write(*,'(a,e12.5)') "Requested precision = ",eps

  boxsize = 1
  dlam = 1/boxsize
  zk = 2*pi/dlam + eye*0.02d0

  call prin2('boxsize in wavelengths = *', boxsize, 1)
  call prin2('dlam = *', dlam, 1)
  call prin2('zk = *', zk, 2)

  !
  ! generate sources uniformly in the unit cube
  !
  h = 1.0d0/(n1+1)
  ijk = 0
  do i = 1,n1
    do j = 1,n1
      do k = 1,n1
        ijk = ijk + 1
        source(1,ijk) = h*i
        source(2,ijk) = h*j
        source(3,ijk) = h*k
      end do
    end do
  end do

  dnorm = 0
  do i=1,ns
    !source(1,i) = hkrand(0)**2
    !source(2,i) = hkrand(0)**2
    !source(3,i) = hkrand(0)**2

    do idim=1,nd

      charge(idim,i) = hkrand(0) + eye*hkrand(0)
      dnorm = dnorm + abs(charge(idim,i))**2

      dipvec(idim,1,i) = hkrand(0) + eye*hkrand(0)
      dipvec(idim,2,i) = hkrand(0) + eye*hkrand(0)
      dipvec(idim,3,i) = hkrand(0) + eye*hkrand(0)

      pot(idim,i) = 0
      grad(idim,1,i) = 0
      grad(idim,2,i) = 0
      grad(idim,3,i) = 0
    enddo
  enddo

  dnorm = sqrt(dnorm)
  do i=1,ns
    do idim = 1,nd
      charge(idim,i) = charge(idim,i)/dnorm
    end do
  end do

  ! call prin2('min source separation = *', ssep, 1)

  shift = h/1000
  call prin2('shift = *', shift, 1)
  do i = 1,ns
    centers(1,i) = source(1,i) + shift
    centers(2,i) = source(2,i)
    centers(3,i) = source(3,i)
  end do

  !call prin2('centers = *', centers, 3*nc)

  !
  ! now form a multipole expansion at each center
  !
  allocate(nterms(nc), impole(nc))

  ntm = 7
  ntot = 0
  do i = 1,nc
    nterms(i) = ntm + 2*cos(pi/2*i)
    ntot = ntot + (nterms(i)+1)*(2*nterms(i)+1)
  end do

  allocate(mpole(nd*ntot))

  impole(1) = 1
  do i = 1,nc-1
    ilen = (nterms(i)+1)*(2*nterms(i)+1)
    impole(i+1) = impole(i) + nd*ilen
  end do

  nlege = 400
  lw = 5*(nlege+1)**2
  allocate( wlege(lw) )

  call prinf('before ylgndrfwini, lw = *', lw, 1)
  call ylgndrfwini(nlege, wlege, lw, lused)
  call prinf('after ylgndrfwini, lused = *', lused, 1)

  call zinitialize(nd*ntot, mpole)

  ns1 = 1
  rscale = 1
  sc = abs(zk)*shift
  if (sc .lt. 1) rscale = sc

  call prin2('rscale = *', rscale, 1)

  allocate(rscales(nc))
  do i = 1,nc
    rscales(i) = rscale
    call h3dformmpc(nd, zk, rscale, source(1,i), charge(1,i), &
        ns1, centers(1,i), nterms(i), mpole(impole(i)), &
        wlege, nlege)
  end do

  !
  ! do the direct calculation
  !
  thresh = 1.0d-15
  ifcharge = 1
  ifdipole = 0
  ifpgh = 1
  ntarg = 0
  ifpghtarg = 0
  call hfmm3d(nd, eps, zk, ns, source, ifcharge, &
      charge, ifdipole, dipvec, iper, ifpgh, pot, grad, hess, ntarg, &
      targ, ifpghtarg, pottarg, gradtarg, hesstarg, ier)

  call prin2('via fmm, potential = *', pot, 10)

  allocate(local(nd*ntot))

  !
  ! now test source to source, charge,
  ! with potentials
  !
  print *
  print *
  print *
  write(6,*) 'testing multipoles to locals'
  write(6,*) 'input: multipole expansions'
  write(6,*) 'output: local expansions'
  write(6,*)
  write(6,*)

  call hfmm3d_mps(nd, eps, zk, &
      nc, centers, rscales, nterms, mpole, impole, local,ier)

  call zinitialize(nd*nc, pot2)
  npts = 1
  do i = 1,nc
    call h3dtaevalp(nd, zk, rscales(i), &
        centers(1,i), local(impole(i)), &
        nterms(i), source(1,i), npts, pot2(1,i), &
        wlege, nlege)
  end do

  call prin2('from hfmm3d_mps, potential = *', pot2, 10)

  err = 0
  dnorm = 0
  do j = 1,nc
    do i = 1,nd
      err = err + abs(pot(i,j)-pot2(i,j))**2
      dnorm = dnorm + abs(pot(i,j))**2
      pot2(i,j) = pot2(i,j) - pot(i,j)
    end do
  end do

  !call prin2('diff = *', pot2, 2*nd*ns)
  !call prin2('err = *', err, 1)
  !call prin2('dnorm = *', dnorm, 1)

  err = sqrt(err/dnorm)
  call prin2('l2 rel err=*',err,1)

  open(unit=33,file='print_testres.txt',access='append')
  isuccess = 0
  ntest = 1
  if(err.lt.eps) isuccess = 1

  write(33,'(a,i1,a,i1,a)') 'Successfully completed ', &
    isuccess,' out of ',ntest,' tests in helm3d_mps testing suite'
  close(33)

  stop
end program

! ----------------------------------------------------------
!
! This is the end of the debugging code.
!
! ----------------------------------------------------------
subroutine prinmp(str, mpole, nterms)
  implicit double precision (a-h,o-z)
  character (len=*) :: str
  double complex :: mpole(0:nterms, -nterms:nterms)
  double complex :: tmp(-10000:10000)

  print *, trim(str)

  do n = 0,nterms
    print *
    write(6,'(a,i2,a,i2,a,i2)') 'n = ', n, '  m = ', -n, '...', n
    do m = -nterms,nterms
      tmp(m) = mpole(n,m)
    end do
    call prin2('coefs = *', tmp(-n), 2*n+1)
  end do

  return
end subroutine prinmp

subroutine zinitialize(len, zs)
  implicit double precision (a-h,o-z)
  double complex :: zs(len)

  do i = 1,len
    zs(i) = 0
  end do
  return
end subroutine zinitialize

subroutine comperr_vec(nd,zk,ns,source,ifcharge,charge,ifdipole, &
    dipvec,ifpgh,pot,grad,nt,targ,ifpghtarg,pottarg, &
    gradtarg,ntest,err)

  implicit none
  double complex zk
  integer ns,nt,ifcharge,ifdipole,ifpgh,ifpghtarg

  double precision source(3,*),targ(3,*)
  double complex dipvec(nd,3,*)
  double complex charge(nd,*)

  double complex pot(nd,*),pottarg(nd,*),grad(nd,3,*), &
      gradtarg(nd,3,*)

  integer i,j,ntest,nd,idim

  double precision err,ra

  double complex potex(nd,ntest),gradex(nd,3,ntest), &
      pottargex(nd,ntest),gradtargex(nd,3,ntest)

  double precision thresh

  err = 0
  do i=1,ntest
    do idim=1,nd
      potex(idim,i) = 0
      pottargex(idim,i) = 0

      gradex(idim,1,i) = 0
      gradex(idim,2,i) = 0
      gradex(idim,3,i) = 0

      gradtargex(idim,1,i) = 0
      gradtargex(idim,2,i) = 0
      gradtargex(idim,3,i) = 0
    enddo
  enddo

  thresh = 1.0d-16

  if(ifcharge.eq.1.and.ifdipole.eq.0) then
    if(ifpgh.eq.1) then
      call h3ddirectcp(nd,zk,source,charge,ns,source,ntest, &
          potex,thresh)
    endif

    if(ifpgh.eq.2) then
      call h3ddirectcg(nd,zk,source,charge,ns,source,ntest, &
          potex,gradex,thresh)
    endif

    if(ifpghtarg.eq.1) then
      call h3ddirectcp(nd,zk,source,charge,ns,targ,ntest, &
          pottargex,thresh)
    endif

    if(ifpghtarg.eq.2) then
      call h3ddirectcg(nd,zk,source,charge,ns,targ,ntest, &
          pottargex,gradtargex,thresh)
    endif
  endif

  if(ifcharge.eq.0.and.ifdipole.eq.1) then
    if(ifpgh.eq.1) then
      call h3ddirectdp(nd,zk,source,dipvec, &
          ns,source,ntest,potex,thresh)
    endif

    if(ifpgh.eq.2) then
      call h3ddirectdg(nd,zk,source,dipvec, &
          ns,source,ntest,potex,gradex,thresh)
    endif

    if(ifpghtarg.eq.1) then
      call h3ddirectdp(nd,zk,source,dipvec, &
          ns,targ,ntest,pottargex,thresh)
    endif

    if(ifpghtarg.eq.2) then
      call h3ddirectdg(nd,zk,source,dipvec, &
          ns,targ,ntest,pottargex,gradtargex,thresh)
    endif
  endif

  if(ifcharge.eq.1.and.ifdipole.eq.1) then
    if(ifpgh.eq.1) then
      call h3ddirectcdp(nd,zk,source,charge,dipvec, &
          ns,source,ntest,potex,thresh)
    endif

    if(ifpgh.eq.2) then
      call h3ddirectcdg(nd,zk,source,charge,dipvec, &
          ns,source,ntest,potex,gradex,thresh)
    endif

    if(ifpghtarg.eq.1) then
      call h3ddirectcdp(nd,zk,source,charge,dipvec, &
          ns,targ,ntest,pottargex,thresh)
    endif

    if(ifpghtarg.eq.2) then
      call h3ddirectcdg(nd,zk,source,charge,dipvec, &
          ns,targ,ntest,pottargex,gradtargex,thresh)
    endif
  endif

  err = 0
  ra = 0

  if(ifpgh.eq.1) then
    do i=1,ntest
      do idim=1,nd
        ra = ra + abs(potex(idim,i))**2
        err = err + abs(pot(idim,i)-potex(idim,i))**2
      enddo
    enddo
  endif

  if(ifpgh.eq.2) then
    do i=1,ntest
      do idim=1,nd
        ra = ra + abs(potex(idim,i))**2
        ra = ra + abs(gradex(idim,1,i))**2
        ra = ra + abs(gradex(idim,2,i))**2
        ra = ra + abs(gradex(idim,3,i))**2

        err = err + abs(pot(idim,i)-potex(idim,i))**2
        err = err + abs(grad(idim,1,i)-gradex(idim,1,i))**2
        err = err + abs(grad(idim,2,i)-gradex(idim,2,i))**2
        err = err + abs(grad(idim,3,i)-gradex(idim,3,i))**2
      enddo
    enddo
  endif

  if(ifpghtarg.eq.1) then
    do i=1,ntest
      do idim=1,nd
        ra = ra + abs(pottargex(idim,i))**2
        err = err + abs(pottarg(idim,i)-pottargex(idim,i))**2
      enddo
    enddo
  endif

  if(ifpghtarg.eq.2) then
    do i=1,ntest
      do idim=1,nd
        ra = ra + abs(pottargex(idim,i))**2
        ra = ra + abs(gradtargex(idim,1,i))**2
        ra = ra + abs(gradtargex(idim,2,i))**2
        ra = ra + abs(gradtargex(idim,3,i))**2

        err = err + abs(pottarg(idim,i)-pottargex(idim,i))**2
        err = err + abs(gradtarg(idim,1,i)-gradtargex(idim,1,i))**2
        err = err + abs(gradtarg(idim,2,i)-gradtargex(idim,2,i))**2
        err = err + abs(gradtarg(idim,3,i)-gradtargex(idim,3,i))**2
      enddo
    enddo
  endif

  err = sqrt(err/ra)
  return
end subroutine comperr_vec


C PROJNE : stands for PROJecton Not Exact.
C It is the same program as renpar6.f, but
C for the function that modifies K.
C In this case, the transformer contains only
C an enequality, and the projection cannot preserve
C the must approximation for the array WORK.

      SUBROUTINE PROJNE(A,N,K,M)
      INTEGER N,K,M,A(N)
      DIMENSION WORK(100,100)
         K = M * M
      IF (K.GT.0) THEN
         DO I = 1,N
            DO J = 1,N
               WORK(J,K) = J + K
            ENDDO

            CALL TOTO(K)

            DO J = 1,N
               WORK(J,K) = J * J - K * K
               A(I) = A(I) + WORK(J,K) + WORK(J,K-1)
            ENDDO
         ENDDO
      ENDIF
      END

      SUBROUTINE TOTO(I)
      IF (I.LT.10) THEN
         I = I + 10
      ENDIF
      END


! RUN: bbc %s -o - | FileCheck %s

! CHECK-LABEL: sign_testi
subroutine sign_testi(a, b, c)
  integer a, b, c
  ! CHECK: %[[VAL_1:.*]] = arith.shrsi %{{.*}}, %{{.*}} : i32
  ! CHECK: %[[VAL_2:.*]] = arith.xori %{{.*}}, %[[VAL_1]] : i32
  ! CHECK: %[[VAL_3:.*]] = arith.subi %[[VAL_2]], %[[VAL_1]] : i32
  ! CHECK-DAG: %[[VAL_4:.*]] = arith.subi %{{.*}}, %[[VAL_3]] : i32
  ! CHECK-DAG: %[[VAL_5:.*]] = arith.cmpi slt, %{{.*}}, %{{.*}} : i32
  ! CHECK: select %[[VAL_5]], %[[VAL_4]], %[[VAL_3]] : i32
  c = sign(a, b)
end subroutine

! CHECK-LABEL: sign_testr
subroutine sign_testr(a, b, c)
  real a, b, c
  ! CHECK-NOT: fir.call @{{.*}}fabs
  ! CHECK: fir.call @{{.*}}copysign{{.*}} : (f32, f32) -> f32
  c = sign(a, b)
end subroutine

! CHECK-LABEL: sign_testr2
subroutine sign_testr2(a, b, c)
  real(KIND=16) a, b, c
  ! CHECK-NOT: fir.call @{{.*}}fabs
  ! CHECK: fir.call @{{.*}}copysign{{.*}} : (f128, f128) -> f128
  c = sign(a, b)
end subroutine


!> \file mo_linear_algebra.f90

!> \brief Wrapper for LAPACK's linear algebra routines.

!> \details This modules provides mostly wrappers for LAPACK's F77 linear algebra routines.
!>          It adds a few convenience functions such as diag.

!> \authors Matthias Cuntz, Sebastian Mueller
!> \date May 2014
MODULE mo_linear_algebra

  ! Wrapper for LAPACK's F77 linear algebra routines.

  ! Written  Matthias Cuntz,    May 2014
  ! Modified Matthias Cuntz,    May 2016 - calc single precision via double precision
  ! Modified Sebastian Mueller, Oct 2016 - solver for banded coefficent-matrices and some involved algorithms
  ! Modified Matthias Cuntz,    Mar 2020 - allocate out of sp routines calling dp routines only if not allocated
  !                                      - allocate out for Python.

  ! License
  ! -------
  ! This file is part of the JAMS Fortran package, distributed under the MIT License.
  !
  ! Copyright (c) 2014-2020 Matthias Cuntz, Sebastian Mueller - mc (at) macu (dot) de
  !
  ! Permission is hereby granted, free of charge, to any person obtaining a copy
  ! of this software and associated documentation files (the "Software"), to deal
  ! in the Software without restriction, including without limitation the rights
  ! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  ! copies of the Software, and to permit persons to whom the Software is
  ! furnished to do so, subject to the following conditions:
  !
  ! The above copyright notice and this permission notice shall be included in all
  ! copies or substantial portions of the Software.
  !
  ! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  ! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  ! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  ! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  ! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  ! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
  ! SOFTWARE.

  USE mo_kind, ONLY: i4, i8, sp, dp

  IMPLICIT NONE

  PUBLIC :: banded                      ! banded form of a given matrix
  PUBLIC :: diag                        ! diagonal of matrix
  PUBLIC :: inverse                     ! inverse of matrix
  PUBLIC :: min_diag                    ! minor diagonal of matrix
  PUBLIC :: solve_linear_equations      ! solve linear system of equations with LU decomposition
  PUBLIC :: solve_linear_equations_svd  ! solve linear system of equations with SVD
  PUBLIC :: solve_linear_equations_band ! solve linear system of equations for banded matrix

  ! ------------------------------------------------------------------
  !
  !     NAME
  !         banded
  !
  !     PURPOSE
  !         Banded form of squared matrix for the banded linear equations solver
  !
  !>        \brief Banded form of squared matrix.
  !
  !>        \details Converts a given squared matrix into the banded form needed for the Lapack-solver for banded matrices.
  !
  !     INTENT(IN)
  !>        \param[in] "real(sp/dp) :: matrix(:,:)"    Squared 2D-array
  !>        \param[in] "integer(i4) :: l          "    number of lower minor-diagonals
  !>        \param[in] "integer(i4) :: u          "    number of upper minor-diagonals
  !
  !     INTENT(INOUT)
  !         None
  !
  !     INTENT(OUT)
  !         None
  !
  !     INTENT(IN), OPTIONAL
  !         None
  !
  !     INTENT(INOUT), OPTIONAL
  !         None
  !
  !     INTENT(OUT), OPTIONAL
  !         None
  !
  !     RETURNS
  !>       \return     real(sp/dp) :: banded(:) — Banded form of input matrix
  !
  !     RESTRICTIONS
  !         None
  !
  !     EXAMPLE
  !         band = banded(matrix,l,u)
  !         -> see also example in test directory

  !     LITERATURE
  !         None

  !     HISTORY
  !>        \author Sebastian Mueller
  !>        \date October 2016
  INTERFACE banded
     MODULE PROCEDURE banded_dp, banded_sp
  END INTERFACE banded

  ! ------------------------------------------------------------------
  !
  !     NAME
  !         diag
  !
  !     PURPOSE
  !         Returns the diagonal of a square 2D-array.
  !
  !>        \brief Diagonal elements of a squared matrix.
  !
  !>        \details Returns the diagonal of a square 2D-array.
  !
  !     INTENT(IN)
  !>        \param[in] "real(sp/dp)/integer(i4/i8)/logical :: matrix(:,:)"    Squared 2D-array
  !
  !     INTENT(INOUT)
  !         None
  !
  !     INTENT(OUT)
  !         None
  !
  !     INTENT(IN), OPTIONAL
  !         None
  !
  !     INTENT(INOUT), OPTIONAL
  !         None
  !
  !     INTENT(OUT), OPTIONAL
  !         None
  !
  !     RETURNS
  !>       \return     real(sp/dp)/integer(i4/i8)/logical :: diag(:) — Diagonal elements of matrix
  !
  !     RESTRICTIONS
  !         None
  !
  !     EXAMPLE
  !         m = diag(matrix)
  !         -> see also example in test directory
  !
  !     LITERATURE
  !         None
  !
  !     HISTORY
  !>        \author Matthias Cuntz
  !>        \date May 2014
  INTERFACE diag
     MODULE PROCEDURE diag_sp, diag_dp, diag_i4, diag_i8, diag_lgt
  END INTERFACE diag

  ! ------------------------------------------------------------------
  !
  !     NAME
  !         inverse
  !
  !     PURPOSE
  !         Inverse of squared matrix
  !
  !>        \brief Inverse of squared matrix.
  !
  !>        \details Inverts squared matrix using LU decomposition.
  !>
  !>                 Uses standard Lapack routines using LU decomposition: dgetrf and dgetri.
  !>                 Conditions columns before decomposition.
  !
  !     INTENT(IN)
  !>        \param[in] "real(sp/dp) :: matrix(:,:)"    Squared 2D-array
  !
  !     INTENT(INOUT)
  !         None
  !
  !     INTENT(OUT)
  !         None
  !
  !     INTENT(IN), OPTIONAL
  !>       \param[in] "logical, optional :: condition" If true, condition matrix before inversion (default: true)
  !
  !     INTENT(INOUT), OPTIONAL
  !         None
  !
  !     INTENT(OUT), OPTIONAL
  !         None
  !
  !     RETURNS
  !>       \return     real(sp/dp) :: inverse(:) — Inverse of input matrix
  !
  !     RESTRICTIONS
  !         None
  !
  !     EXAMPLE
  !         inv = inverse(matrix)
  !         -> see also example in test directory

  !     LITERATURE
  !         None

  !     HISTORY
  !>        \author Matthias Cuntz
  !>        \date May 2014
  INTERFACE inverse
     MODULE PROCEDURE inverse_dp, inverse_sp
  END INTERFACE inverse

  ! ------------------------------------------------------------------
  !
  !     NAME
  !         min_diag
  !
  !     PURPOSE
  !         Returns the n-th minor-diagonal of a square 2D-array, where positive n indicate super-diagonals and negativ n indicate
  !         sub-diagonals.
  !
  !>        \brief Minor-diagonal elements of a squared matrix.
  !
  !>        \details Returns the n-th minor-diagonal of a square 2D-array.
  !
  !     INTENT(IN)
  !>        \param[in] "real(sp/dp)/integer(i4/i8)/logical :: matrix(:,:)"    Squared 2D-array
  !>        \param[in] "integer(i4)                        :: n          "    number of minor-diagonal
  !
  !     INTENT(INOUT)
  !         None
  !
  !     INTENT(OUT)
  !         None
  !
  !     INTENT(IN), OPTIONAL
  !         None
  !
  !     INTENT(INOUT), OPTIONAL
  !         None
  !
  !     INTENT(OUT), OPTIONAL
  !         None
  !
  !     RETURNS
  !>       \return     real(sp/dp)/integer(i4/i8)/logical :: min_diag(:) — n-th minor-diagonal elements of matrix
  !
  !     RESTRICTIONS
  !         None
  !
  !     EXAMPLE
  !         m = min_diag(matrix,n)
  !         -> see also example in test directory
  !
  !     LITERATURE
  !         None
  !
  !     HISTORY
  !>        \author Sebastian Mueller
  !>        \date October 2016
  INTERFACE min_diag
     MODULE PROCEDURE min_diag_sp, min_diag_dp, min_diag_i4, min_diag_i8, min_diag_lgt
  END INTERFACE min_diag

  ! ------------------------------------------------------------------
  !
  !     NAME
  !         solve_linear_equations
  !
  !     PURPOSE
  !         Solve linear system of equations
  !
  !>        \brief Solve linear system of equations.
  !
  !>        \details Solve linear system of equations using LU decomposition
  !>                 \f[ A x = b \f]
  !>                 Returns \f$ x \f$.
  !>
  !>                 Uses standard Lapack routine using LU decomposition: dgesv.
  !>                 Conditions rows and columns before decomposition.
  !
  !     INTENT(IN)
  !>        \param[in] "real(sp/dp) :: lhs(:,:)"    Coefficients of left hand side \f$ A \f$
  !>        \param[in] "real(sp/dp) :: rhs(:)"      Right hand side \f$ b \f$
  !
  !     INTENT(INOUT)
  !         None
  !
  !     INTENT(OUT)
  !         None
  !
  !     INTENT(IN), OPTIONAL
  !>       \param[in] "logical, optional :: condition" If true, condition lhs and rhs before decomposition (default: true)
  !
  !     INTENT(INOUT), OPTIONAL
  !         None
  !
  !     INTENT(OUT), OPTIONAL
  !         None
  !
  !     RETURNS
  !>       \return     real(sp/dp) :: x(:) — Solution x to \f$ A x = b \f$
  !
  !     RESTRICTIONS
  !         Only one right-hand side.
  !
  !     EXAMPLE
  !         sol = solve_linear_equations(lhs, rhs)
  !         -> see also example in test directory

  !     LITERATURE
  !         None

  !     HISTORY
  !>        \author Matthias Cuntz
  !>        \date May 2014
  INTERFACE solve_linear_equations
     MODULE PROCEDURE solve_linear_equations_1_dp, solve_linear_equations_1_sp
  END INTERFACE solve_linear_equations

  ! ------------------------------------------------------------------
  !
  !     NAME
  !         solve_linear_equations_svd
  !
  !     PURPOSE
  !         Solve linear system of equations
  !
  !>        \brief Solve linear system of equations.
  !
  !>        \details Solve linear system of equations using singular value decomposition
  !>                 \f[ A x = b \f]
  !>                 Returns \f$ x \f$.
  !>
  !>                 Uses standard Lapack routine to do SVD: dgesvd.
  !>                 then solving routine similar to Numerical Recipes: svdksb.
  !>                 It conditions rows and columns before decomposition.
  !
  !     INTENT(IN)
  !>        \param[in] "real(sp/dp) :: lhs(:,:)"    Coefficients of left hand side \f$ A \f$
  !>        \param[in] "real(sp/dp) :: rhs(:)"      Right hand side \f$ b \f$
  !
  !     INTENT(INOUT)
  !         None
  !
  !     INTENT(OUT)
  !         None
  !
  !     INTENT(IN), OPTIONAL
  !>       \param[in] "logical, optional :: condition" If true, condition lhs and rhs before decomposition (default: true)
  !
  !     INTENT(INOUT), OPTIONAL
  !         None
  !
  !     INTENT(OUT), OPTIONAL
  !         None
  !
  !     RETURNS
  !>       \return     real(sp/dp) :: x(:) — Solution x to \f$ A x = b \f$
  !
  !     RESTRICTIONS
  !         Only one right-hand side.
  !
  !     EXAMPLE
  !         sol = solve_linear_equations_svd(lhs, rhs)
  !         -> see also example in test directory

  !     LITERATURE
  !         Press WH, Teukolsky SA, Vetterling WT, & Flannery BP - Numerical Recipes in Fortran 90 -
  !             The Art of Parallel Scientific Computing, 2nd Edition, Volume 2 of Fortran Numerical Recipes,
  !             Cambridge University Press, UK, 1996

  !     HISTORY
  !>        \author Matthias Cuntz
  !>        \date May 2014
  INTERFACE solve_linear_equations_svd
     MODULE PROCEDURE solve_linear_equations_svd_1_dp, solve_linear_equations_svd_1_sp
  END INTERFACE solve_linear_equations_svd

  ! ------------------------------------------------------------------
  !
  !     NAME
  !         solve_linear_equations_band
  !
  !     PURPOSE
  !         Solve linear system of equations for a banded matrix A=(aij).
  !         The band storage scheme is illustrated by the following example, when
  !         N = 6, l = 2, u = 1:
  !
  !             *   a12  a23  a34  a45  a56
  !            a11  a22  a33  a44  a55  a66
  !            a21  a32  a43  a54  a65   *
  !            a31  a42  a53  a64   *    *
  !
  !         Array elements marked * are not used by the routine. You can set them zero.
  !
  !>        \brief Solve linear system of equations.
  !
  !>        \details Solve linear system of equations for banded coefficent-matrix
  !>                 \f[ A x = b \f]
  !>                 Returns \f$ x \f$.
  !>
  !>                 Uses standard Lapack routine for banded matrix: dgbsv.
  !>                 Conditions columns before decomposition.
  !
  !     INTENT(IN)
  !>        \param[in] "real(sp/dp) :: lhsb(:,:)"    Coefficients of left hand side in banded form of \f$ A \f$
  !>        \param[in] "real(sp/dp) :: rhs(:)   "    Right hand side \f$ b \f$
  !>        \param[in] "integer(i4) :: l        "    number of lower minor-diagonals
  !>        \param[in] "integer(i4) :: u        "    number of upper minor-diagonals
  !
  !     INTENT(INOUT)
  !         None
  !
  !     INTENT(OUT)
  !         None
  !
  !     INTENT(IN), OPTIONAL
  !>       \param[in] "logical, optional :: condition" If true, condition lhsb before decomposition (default: true)
  !
  !     INTENT(INOUT), OPTIONAL
  !         None
  !
  !     INTENT(OUT), OPTIONAL
  !         None
  !
  !     RETURNS
  !>       \return     real(sp/dp) :: x(:) — Solution x to \f$ A x = b \f$
  !
  !     RESTRICTIONS
  !         Only one right-hand side.
  !         Left-hand side needs to be in banded form. You can use the banded-function to convert a given squared matrix.
  !
  !     EXAMPLE
  !         sol = solve_linear_equations_band(lhsb, rhs, l, u)
  !         sol = solve_linear_equations_band(banded(lhs), rhs, l, u)
  !         -> see also example in test directory

  !     LITERATURE
  !         None

  !     HISTORY
  !>        \author Sebastian Mueller
  !>        \date October 2016
  !         Modified, Matthias Cuntz, May 2018 - allocate output for solve_linear_equations_band_1_sp
  INTERFACE solve_linear_equations_band
     MODULE PROCEDURE solve_linear_equations_band_1_dp, solve_linear_equations_band_1_sp
  END INTERFACE solve_linear_equations_band

  PRIVATE

  INTERFACE svdksb
     MODULE PROCEDURE svdksb_dp, svdksb_sp
  END INTERFACE svdksb

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

CONTAINS

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

  FUNCTION banded_dp(matrix, l, u)

    IMPLICIT NONE

    REAL(dp), DIMENSION(:,:), INTENT(IN)   :: matrix
    INTEGER(i4),              INTENT(IN)   :: l, u
#ifndef __PYTHON__
    REAL(dp), DIMENSION(:,:), allocatable  :: banded_dp
#else
    REAL(dp), DIMENSION(l+u+1,size(matrix,1)) :: banded_dp
#endif

    INTEGER(i4) :: i

    if (size(matrix,1) /= size(matrix,2)) stop 'banded_dp: array must be squared matrix.'
    if (l              >= size(matrix,1)) stop 'banded_dp: l is to big. You need to choose minor diagonals within the matrix.'
    if (u              >= size(matrix,1)) stop 'banded_dp: u is to big. You need to choose minor diagonals within the matrix.'
    if (l              <  0_i4          ) stop 'banded_dp: l needs to be non-negativ.'
    if (u              <  0_i4          ) stop 'banded_dp: u needs to be non-negativ.'
#ifndef __PYTHON__
    if (.not. allocated(banded_dp)) allocate(banded_dp(l+u+1,size(matrix,1)))
#endif

    banded_dp = 0.0_dp

    do i=0_i4,u
        banded_dp(u+1-i,i+1:size(matrix,1)) = min_diag_dp(matrix, i)
    end do

    do i=1_i4,l
        banded_dp(u+1+i,1:size(matrix,1)-i) = min_diag_dp(matrix,-i)
    end do

  END FUNCTION banded_dp

  FUNCTION banded_sp(matrix, l, u)

    IMPLICIT NONE

    REAL(sp), DIMENSION(:,:), INTENT(IN)   :: matrix
    INTEGER(i4),              INTENT(IN)   :: l, u
#ifndef __PYTHON__
    REAL(sp), DIMENSION(:,:), allocatable  :: banded_sp
#else
    REAL(sp), DIMENSION(l+u+1,size(matrix,1)) :: banded_sp
#endif

    INTEGER(i4) :: i

    if (size(matrix,1) /= size(matrix,2)) stop 'banded_sp: array must be squared matrix.'
    if (l              >= size(matrix,1)) stop 'banded_sp: l is to big. You need to choose minor diagonals within the matrix.'
    if (u              >= size(matrix,1)) stop 'banded_sp: u is to big. You need to choose minor diagonals within the matrix.'
    if (l              <  0_i4          ) stop 'banded_sp: l needs to be non-negativ.'
    if (u              <  0_i4          ) stop 'banded_sp: u needs to be non-negativ.'
#ifndef __PYTHON__
    if (.not. allocated(banded_sp)) allocate(banded_sp(l+u+1,size(matrix,1)))
#endif

    banded_sp = 0.0_sp

    do i=0_i4,u
        banded_sp(u+1-i,i+1:size(matrix,1)) = min_diag_sp(matrix, i)
    end do

    do i=1_i4,l
        banded_sp(u+1+i,1:size(matrix,1)-i) = min_diag_sp(matrix,-i)
    end do

  END FUNCTION banded_sp

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

  FUNCTION diag_dp(matrix)

    IMPLICIT NONE

    REAL(dp), DIMENSION(:,:), INTENT(IN) :: matrix
#ifndef __PYTHON__
    REAL(dp), DIMENSION(:), allocatable  :: diag_dp
#else
    REAL(dp), DIMENSION(size(matrix,1)) :: diag_dp
#endif

    INTEGER(i4) :: i

    if (size(matrix,1) /= size(matrix,2)) stop 'diag_dp: array must be squared matrix.'
#ifndef __PYTHON__
    if (.not. allocated(diag_dp)) allocate(diag_dp(size(matrix,1)))
#endif

    forall(i=1:size(matrix,1)) diag_dp(i) = matrix(i,i)

  END FUNCTION diag_dp

  FUNCTION diag_sp(matrix)

    IMPLICIT NONE

    REAL(sp), DIMENSION(:,:), INTENT(IN) :: matrix
#ifndef __PYTHON__
    REAL(sp), DIMENSION(:), allocatable  :: diag_sp
#else
    REAL(sp), DIMENSION(size(matrix,1)) :: diag_sp
#endif

    INTEGER(i4) :: i

    if (size(matrix,1) /= size(matrix,2)) stop 'diag_sp: array must be squared matrix.'
#ifndef __PYTHON__
    if (.not. allocated(diag_sp)) allocate(diag_sp(size(matrix,1)))
#endif

    forall(i=1:size(matrix,1)) diag_sp(i) = matrix(i,i)

  END FUNCTION diag_sp

  FUNCTION diag_i4(matrix)

    IMPLICIT NONE

    INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: matrix
#ifndef __PYTHON__
    INTEGER(i4), DIMENSION(:), allocatable  :: diag_i4
#else
    INTEGER(i4), DIMENSION(size(matrix,1)) :: diag_i4
#endif

    INTEGER(i4) :: i

    if (size(matrix,1) /= size(matrix,2)) stop 'diag_i4: array must be squared matrix.'
#ifndef __PYTHON__
    if (.not. allocated(diag_i4)) allocate(diag_i4(size(matrix,1)))
#endif

    forall(i=1:size(matrix,1)) diag_i4(i) = matrix(i,i)

  END FUNCTION diag_i4

  FUNCTION diag_i8(matrix)

    IMPLICIT NONE

    INTEGER(i8), DIMENSION(:,:), INTENT(IN) :: matrix
#ifndef __PYTHON__
    INTEGER(i8), DIMENSION(:), allocatable  :: diag_i8
#else
    INTEGER(i8), DIMENSION(size(matrix,1)) :: diag_i8
#endif

    INTEGER(i8) :: i

    if (size(matrix,1) /= size(matrix,2)) stop 'diag_i8: array must be squared matrix.'
#ifndef __PYTHON__
    if (.not. allocated(diag_i8)) allocate(diag_i8(size(matrix,1)))
#endif

    forall(i=1:size(matrix,1)) diag_i8(i) = matrix(i,i)

  END FUNCTION diag_i8

  FUNCTION diag_lgt(matrix)

    IMPLICIT NONE

    LOGICAL, DIMENSION(:,:), INTENT(IN) :: matrix
#ifndef __PYTHON__
    LOGICAL, DIMENSION(:), allocatable  :: diag_lgt
#else
    LOGICAL, DIMENSION(size(matrix,1)) :: diag_lgt
#endif

    INTEGER(i4) :: i

    if (size(matrix,1) /= size(matrix,2)) stop 'diag_lgt: array must be squared matrix.'
#ifndef __PYTHON__
    if (.not. allocated(diag_lgt)) allocate(diag_lgt(size(matrix,1)))
#endif

    forall(i=1:size(matrix,1)) diag_lgt(i) = matrix(i,i)

  END FUNCTION diag_lgt

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

  FUNCTION inverse_dp(matrix, condition)

    IMPLICIT NONE

    REAL(dp), DIMENSION(:,:), INTENT(IN)  :: matrix
    LOGICAL,  OPTIONAL,       INTENT(IN)  :: condition
#ifndef __PYTHON__
    REAL(dp), DIMENSION(:,:), allocatable :: inverse_dp
#else
    REAL(dp), DIMENSION(size(matrix,2),size(matrix,1)) :: inverse_dp
#endif

    INTEGER(i4) :: i, nn
    real(dp),    dimension(:),   allocatable :: scale_cols    ! scale matrix for better conditioning
    integer(i4), dimension(:),   allocatable :: ipiv          ! needed for dgetrf lapack routine
    integer(i4)                              :: info          !              "
    real(dp),    dimension(:),   allocatable :: work          ! needed for dgetri lapack routine
    integer(i4)                              :: lwork         !              "
    logical :: icondition

    external :: dgetrf ! Lapack routine to compute LU factorization of a general matrix
    external :: dgetri ! Lapack routine to compute inverse of matrix using the LU factorization computed by DGETRF

    nn = size(matrix,2)
    if (size(matrix,1) /= nn) stop 'inverse_dp: matrix must be square.'
#ifndef __PYTHON__
    if (.not. allocated(inverse_dp)) allocate(inverse_dp(nn,nn))
#endif
    inverse_dp = matrix

    if (present(condition)) then
       icondition = condition
    else
       icondition = .true.
    endif

    if (icondition) then
       ! Condition columns
       allocate(scale_cols(nn))
       scale_cols(:) = maxval(abs(inverse_dp(:,:)),1)
       where (scale_cols(:) < tiny(1.0_dp)) scale_cols(:) = 1.0_dp
       scale_cols(:) = 1.0_dp / scale_cols(:)
       forall(i=1:nn) inverse_dp(:,i) = inverse_dp(:,i) * scale_cols(i)
    endif

    ! LU factorisation of imatrix
    allocate(ipiv(nn))
    call dgetrf(nn, nn, inverse_dp, nn, ipiv, info)
    if (info /= 0) stop 'inverse_dp: LU factorisation did not work.'
    ! Inverse of LU factorisation of imatrix
    allocate(work(1))
    call dgetri(nn, inverse_dp, nn, ipiv, work, -1, info)
    lwork = int(work(1),i4)
    deallocate(work)
    allocate(work(lwork))
    call dgetri(nn, inverse_dp, nn, ipiv, work, lwork, info)
    if (info /= 0) stop 'hdmr_hessian: Inversion did not work.'

    if (icondition) then
       ! rescale result
       forall(i=1:nn) inverse_dp(i,:) = inverse_dp(i,:) * scale_cols(i)

       deallocate(scale_cols)
    endif

    deallocate(ipiv)

  END FUNCTION inverse_dp

  FUNCTION inverse_sp(matrix, condition)

    IMPLICIT NONE

    REAL(sp), DIMENSION(:,:), INTENT(IN)  :: matrix
    LOGICAL,  OPTIONAL,       INTENT(IN)  :: condition
#ifndef __PYTHON__
    REAL(sp), DIMENSION(:,:), allocatable :: inverse_sp
#else
    REAL(sp), DIMENSION(size(matrix,2),size(matrix,1)) :: inverse_sp
#endif

#ifndef __PYTHON__
    if (.not. allocated(inverse_sp)) allocate(inverse_sp(size(matrix,2),size(matrix,1)))
#endif
    inverse_sp = real(inverse_dp(real(matrix,dp), condition), sp)

  END FUNCTION inverse_sp

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

  FUNCTION min_diag_dp(matrix, n)

    IMPLICIT NONE

    REAL(dp), DIMENSION(:,:), INTENT(IN) :: matrix
    INTEGER(i4),              INTENT(IN) :: n
#ifndef __PYTHON__
    REAL(dp), DIMENSION(:), allocatable  :: min_diag_dp
#else
    REAL(dp), DIMENSION(size(matrix,1)-abs(n)) :: min_diag_dp
#endif

    if (size(matrix,1) /= size(matrix,2)) stop 'min_diag_dp: array must be squared matrix.'
    if (abs(n)         >= size(matrix,1)) stop 'min_diag_dp: n is to big. You need to choose a minor diagonal within the matrix.'
#ifndef __PYTHON__
    if (.not. allocated(min_diag_dp)) allocate(min_diag_dp(size(matrix,1) - abs(n)))
#endif

    if (n >= 0_i4) then
        min_diag_dp = diag_dp(matrix(1_i4:size(matrix,1)-n,1_i4+n:size(matrix,1)))
    else
        min_diag_dp = diag_dp(matrix(1_i4-n:size(matrix,1),1_i4:size(matrix,1)+n))
    end if

  END FUNCTION min_diag_dp

  FUNCTION min_diag_sp(matrix, n)

    IMPLICIT NONE

    REAL(sp), DIMENSION(:,:), INTENT(IN) :: matrix
    INTEGER(i4),              INTENT(IN) :: n
#ifndef __PYTHON__
    REAL(sp), DIMENSION(:), allocatable  :: min_diag_sp
#else
    REAL(sp), DIMENSION(size(matrix,1)-abs(n)) :: min_diag_sp
#endif

    if (size(matrix,1) /= size(matrix,2)) stop 'min_diag_sp: array must be squared matrix.'
    if (abs(n)         >= size(matrix,1)) stop 'min_diag_sp: n is to big. You need to choose a minor diagonal within the matrix.'
#ifndef __PYTHON__
    if (.not. allocated(min_diag_sp)) allocate(min_diag_sp(size(matrix,1) - abs(n)))
#endif

    if (n >= 0_i4) then
        min_diag_sp = diag_sp(matrix(1_i4:size(matrix,1)-n,1_i4+n:size(matrix,1)))
    else
        min_diag_sp = diag_sp(matrix(1_i4-n:size(matrix,1),1_i4:size(matrix,1)+n))
    end if

  END FUNCTION min_diag_sp

  FUNCTION min_diag_i4(matrix, n)

    IMPLICIT NONE

    INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: matrix
    INTEGER(i4),                 INTENT(IN) :: n
#ifndef __PYTHON__
    INTEGER(i4), DIMENSION(:), allocatable  :: min_diag_i4
#else
    INTEGER(i4), DIMENSION(size(matrix,1)-abs(n)) :: min_diag_i4
#endif

    if (size(matrix,1) /= size(matrix,2)) stop 'min_diag_i4: array must be squared matrix.'
    if (abs(n)         >= size(matrix,1)) stop 'min_diag_i4: n is to big. You need to choose a minor diagonal within the matrix.'
#ifndef __PYTHON__
    if (.not. allocated(min_diag_i4)) allocate(min_diag_i4(size(matrix,1) - abs(n)))
#endif

    if (n >= 0_i4) then
        min_diag_i4 = diag_i4(matrix(1_i4:size(matrix,1)-n,1_i4+n:size(matrix,1)))
    else
        min_diag_i4 = diag_i4(matrix(1_i4-n:size(matrix,1),1_i4:size(matrix,1)+n))
    end if

  END FUNCTION min_diag_i4

  FUNCTION min_diag_i8(matrix, n)

    IMPLICIT NONE

    INTEGER(i8), DIMENSION(:,:), INTENT(IN) :: matrix
    INTEGER(i4),                 INTENT(IN) :: n
#ifndef __PYTHON__
    INTEGER(i8), DIMENSION(:), allocatable  :: min_diag_i8
#else
    INTEGER(i8), DIMENSION(size(matrix,1)-abs(n)) :: min_diag_i8
#endif

    if (size(matrix,1) /= size(matrix,2)) stop 'min_diag_i8: array must be squared matrix.'
    if (abs(n)         >= size(matrix,1)) stop 'min_diag_i8: n is to big. You need to choose a minor diagonal within the matrix.'
#ifndef __PYTHON__
    if (.not. allocated(min_diag_i8)) allocate(min_diag_i8(size(matrix,1) - abs(n)))
#endif

    if (n >= 0_i4) then
        min_diag_i8 = diag_i8(matrix(1_i4:size(matrix,1)-n,1_i4+n:size(matrix,1)))
    else
        min_diag_i8 = diag_i8(matrix(1_i4-n:size(matrix,1),1_i4:size(matrix,1)+n))
    end if

  END FUNCTION min_diag_i8

  FUNCTION min_diag_lgt(matrix, n)

    IMPLICIT NONE

    LOGICAL, DIMENSION(:,:), INTENT(IN) :: matrix
    INTEGER(i4),             INTENT(IN) :: n
#ifndef __PYTHON__
    LOGICAL, DIMENSION(:), allocatable  :: min_diag_lgt
#else
    LOGICAL, DIMENSION(size(matrix,1)-abs(n)) :: min_diag_lgt
#endif

    if (size(matrix,1) /= size(matrix,2)) stop 'min_diag_lgt: array must be squared matrix.'
    if (abs(n)         >= size(matrix,1)) stop 'min_diag_lgt: n is to big. You need to choose a minor diagonal within the matrix.'
#ifndef __PYTHON__
    if (.not. allocated(min_diag_lgt)) allocate(min_diag_lgt(size(matrix,1) - abs(n)))
#endif

    if (n >= 0_i4) then
        min_diag_lgt = diag_lgt(matrix(1_i4:size(matrix,1)-n,1_i4+n:size(matrix,1)))
    else
        min_diag_lgt = diag_lgt(matrix(1_i4-n:size(matrix,1),1_i4:size(matrix,1)+n))
    end if

  END FUNCTION min_diag_lgt

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

  FUNCTION solve_linear_equations_1_dp(lhs, rhs, condition)

    IMPLICIT NONE

    REAL(dp), DIMENSION(:,:), INTENT(IN) :: lhs
    REAL(dp), DIMENSION(:),   INTENT(IN) :: rhs
    LOGICAL,  OPTIONAL,       INTENT(IN) :: condition
#ifndef __PYTHON__
    REAL(dp), DIMENSION(:), allocatable  :: solve_linear_equations_1_dp
#else
    REAL(dp), DIMENSION(size(lhs,1)) :: solve_linear_equations_1_dp
#endif

    INTEGER(i4) :: ii, nZeilen
    real(dp),    dimension(:,:), allocatable :: ilhs          ! internal lhs
    real(dp),    dimension(:),   allocatable :: irhs          ! internal rhs
    real(dp),    dimension(:),   allocatable :: scale_cols    ! scale matrix for better conditioning
    real(dp),    dimension(:),   allocatable :: scale_rows    !              "
    integer(i4), dimension(:),   allocatable :: ipiv          ! needed for dgesv lapack routine
    integer(i4)                              :: info          !              "
    logical :: icondition

    external :: dgesv  ! Lapack routine to compute solution of real system of linear equations

    nZeilen = size(lhs,1)
    if (size(lhs,2) /= nZeilen) stop 'solve_linear_equations_1_dp: left hand side must be squared matrix.'
    if (size(rhs,1) /= nZeilen) stop 'solve_linear_equations_1_dp: right hand side must have same size as left hand side.'
    ! internal arrays
    allocate(ilhs(nZeilen,nZeilen), irhs(nZeilen))
    ilhs = lhs
    irhs = rhs

    if (present(condition)) then
       icondition = condition
    else
       icondition = .true.
    endif

    if (icondition) then
       ! Condition of matrix
       allocate(scale_cols(nZeilen), scale_rows(nZeilen))
       ! Condition columns
       scale_cols(:) = maxval(abs(ilhs(:,:)),1)
       where (scale_cols(:) < tiny(1.0_dp)) scale_cols(:) = 1.0_dp
       scale_cols(:) = 1.0_dp / scale_cols(:)
       forall(ii=1:nZeilen) ilhs(:,ii) = ilhs(:,ii) * scale_cols(ii)
       ! Condition rows
       scale_rows(:) = maxval(abs(ilhs(:,:)),2)
       where (scale_rows(:) < tiny(1.0_dp)) scale_rows(:) = 1.0_dp
       scale_rows(:) = 1.0_dp / scale_rows(:)
       forall(ii=1:nZeilen) ilhs(ii,:) = ilhs(ii,:) * scale_rows(ii)
       irhs(:) = irhs(:) * scale_rows(:)
    endif

    ! solve linear system of equations
    allocate(ipiv(nZeilen))
    call dgesv(nZeilen, 1, ilhs, nZeilen, ipiv, irhs, nZeilen, info)
    if (info /= 0) stop 'solve_linear_equations_1_dp: Solving of linear system did not work.'

#ifndef __PYTHON__
    if (.not. allocated(solve_linear_equations_1_dp)) allocate(solve_linear_equations_1_dp(nZeilen))
#endif
    solve_linear_equations_1_dp = irhs

    if (icondition) then
       ! rescale result
       solve_linear_equations_1_dp(:) = solve_linear_equations_1_dp(:) * scale_cols(:)

       deallocate(scale_cols, scale_rows)
    endif

    deallocate(ilhs, irhs)
    deallocate(ipiv)

  END FUNCTION solve_linear_equations_1_dp

  FUNCTION solve_linear_equations_1_sp(lhs, rhs, condition)

    IMPLICIT NONE

    REAL(sp), DIMENSION(:,:), INTENT(IN) :: lhs
    REAL(sp), DIMENSION(:),   INTENT(IN) :: rhs
    LOGICAL,  OPTIONAL,       INTENT(IN) :: condition
#ifndef __PYTHON__
    REAL(sp), DIMENSION(:), allocatable  :: solve_linear_equations_1_sp
#else
    REAL(sp), DIMENSION(size(rhs,1)) :: solve_linear_equations_1_sp
#endif

#ifndef __PYTHON__
    if (.not. allocated(solve_linear_equations_1_sp)) allocate(solve_linear_equations_1_sp(size(rhs,1)))
#endif
    solve_linear_equations_1_sp = real(solve_linear_equations_1_dp(real(lhs,dp), real(rhs,dp), condition), sp)

  END FUNCTION solve_linear_equations_1_sp

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

  FUNCTION solve_linear_equations_svd_1_dp(lhs, rhs, condition)

    IMPLICIT NONE

    REAL(dp), DIMENSION(:,:), INTENT(IN) :: lhs
    REAL(dp), DIMENSION(:),   INTENT(IN) :: rhs
    LOGICAL,  OPTIONAL,       INTENT(IN) :: condition
#ifndef __PYTHON__
    REAL(dp), DIMENSION(:), allocatable  :: solve_linear_equations_svd_1_dp
#else
    REAL(dp), DIMENSION(size(lhs,1)) :: solve_linear_equations_svd_1_dp
#endif

    INTEGER(i4) :: ii, nZeilen
    real(dp),    dimension(:,:), allocatable :: ilhs          ! internal lhs
    real(dp),    dimension(:),   allocatable :: irhs          ! internal rhs
    real(dp),    dimension(:),   allocatable :: scale_cols    ! scale matrix for better conditioning
    real(dp),    dimension(:),   allocatable :: scale_rows    !              "
    real(dp),    dimension(:),   allocatable :: work          ! needed for dgesvd lapack routine
    real(dp),    dimension(:),   allocatable :: svdw          !              "
    real(dp),    dimension(:,:), allocatable :: svdu          !              "
    real(dp),    dimension(:,:), allocatable :: svdv          !              "
    integer(i4)                              :: lwork         !              "
    integer(i4)                              :: info          !              "
    real(dp),    parameter                   :: svdtol = 1.0e-5_dp ! if <svdtol*maxval(svdw), then set svdw=0
    logical :: icondition

    external :: dgesvd ! Lapack routine to compute singular value decomposition of matrix

    nZeilen = size(lhs,1)
    if (size(lhs,2) /= nZeilen) stop 'solve_linear_equations_svd_1_dp: left hand side must be squared matrix.'
    if (size(rhs,1) /= nZeilen) stop 'solve_linear_equations_svd_1_dp: right hand side must have same size as left hand side.'
    ! internal arrays
    allocate(ilhs(nZeilen,nZeilen), irhs(nZeilen))
    ilhs = lhs
    irhs = rhs

    if (present(condition)) then
       icondition = condition
    else
       icondition = .true.
    endif

    if (icondition) then
       ! Condition of matrix
       allocate(scale_cols(nZeilen), scale_rows(nZeilen))
       ! Condition columns
       scale_cols(:) = maxval(abs(ilhs(:,:)),1)
       where (scale_cols(:) < tiny(1.0_dp)) scale_cols(:) = 1.0_dp
       scale_cols(:) = 1.0_dp / scale_cols(:)
       forall(ii=1:nZeilen) ilhs(:,ii) = ilhs(:,ii) * scale_cols(ii)
       ! Condition rows
       scale_rows(:) = maxval(abs(ilhs(:,:)),2)
       where (scale_rows(:) < tiny(1.0_dp)) scale_rows(:) = 1.0_dp
       scale_rows(:) = 1.0_dp / scale_rows(:)
       forall(ii=1:nZeilen) ilhs(ii,:) = ilhs(ii,:) * scale_rows(ii)
       irhs(:) = irhs(:) * scale_rows(:)
    endif

    ! solve linear system of equations
    ! Use Lapack singular value decomposition and Numerical Recipes solution
    allocate(work(1))
    allocate(svdu(nZeilen,nZeilen), svdv(nZeilen,nZeilen), svdw(nZeilen))
    call dgesvd('A', 'A', nZeilen, nZeilen, ilhs, nZeilen, svdw, svdu, nZeilen, svdv, nZeilen, work, -1, info)
    lwork = int(work(1),i4)
    deallocate(work)
    allocate(work(lwork))
    call dgesvd('A', 'A', nZeilen, nZeilen, ilhs, nZeilen, svdw, svdu, nZeilen, svdv, nZeilen, work, lwork, info)
    if (info /= 0) stop 'solve_linear_equations_svd_1_dp: Solving of linear system did not work.'
    ! write(*,*) 'Matrix condition ', maxval(abs(svdw))/minval(abs(svdw))
    where (svdw < svdtol*maxval(svdw)) svdw = 0.0_dp

#ifndef __PYTHON__
    if (.not. allocated(solve_linear_equations_svd_1_dp)) allocate(solve_linear_equations_svd_1_dp(nZeilen))
#endif
    ! svdv is V**T from dgesvd, svdksb wants V
    solve_linear_equations_svd_1_dp = svdksb(svdu,svdw,transpose(svdv),irhs)

    if (icondition) then
       ! rescale result
       solve_linear_equations_svd_1_dp(:) = solve_linear_equations_svd_1_dp(:) * scale_cols(:)

       deallocate(scale_cols, scale_rows)
    endif

    deallocate(ilhs, irhs)
    deallocate(work, svdu, svdv, svdw)

  END FUNCTION solve_linear_equations_svd_1_dp

  FUNCTION solve_linear_equations_svd_1_sp(lhs, rhs, condition)

    IMPLICIT NONE

    REAL(sp), DIMENSION(:,:), INTENT(IN) :: lhs
    REAL(sp), DIMENSION(:),   INTENT(IN) :: rhs
    LOGICAL,  OPTIONAL,       INTENT(IN) :: condition
#ifndef __PYTHON__
    REAL(sp), DIMENSION(:), allocatable  :: solve_linear_equations_svd_1_sp
#else
    REAL(sp), DIMENSION(size(rhs,1)) :: solve_linear_equations_svd_1_sp
#endif

#ifndef __PYTHON__
    if (.not. allocated(solve_linear_equations_svd_1_sp)) allocate(solve_linear_equations_svd_1_sp(size(rhs,1)))
#endif
    solve_linear_equations_svd_1_sp = real(solve_linear_equations_svd_1_dp(real(lhs,dp), real(rhs,dp), condition), sp)

  END FUNCTION solve_linear_equations_svd_1_sp

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

  FUNCTION solve_linear_equations_band_1_dp(lhsb, rhs, l, u, condition)

    IMPLICIT NONE

    REAL(dp), DIMENSION(:,:), INTENT(IN) :: lhsb !banded form of the lhs
    REAL(dp), DIMENSION(:),   INTENT(IN) :: rhs
    INTEGER(i4),              INTENT(IN) :: l, u
    LOGICAL,  OPTIONAL,       INTENT(IN) :: condition
#ifndef __PYTHON__
    REAL(dp), DIMENSION(:), allocatable  :: solve_linear_equations_band_1_dp
#else
    REAL(dp), DIMENSION(size(rhs,1)) :: solve_linear_equations_band_1_dp
#endif

    INTEGER(i4) :: ii, nSpalten, nZeilen
    real(dp),    dimension(:,:), allocatable :: ilhsb         ! internal lhsb
    real(dp),    dimension(:),   allocatable :: irhs          ! internal rhs
    real(dp),    dimension(:),   allocatable :: scale_cols    ! scale matrix for better conditioning
!    real(dp),    dimension(:),   allocatable :: scale_rows    !              "
    integer(i4), dimension(:),   allocatable :: ipiv          ! needed for dgesv lapack routine
    integer(i4)                              :: info          !              "
    logical :: icondition

    external :: dgbsv  ! Lapack routine to compute solution of real system of linear equations with banded matrix

    nZeilen  = size(lhsb,1)
    nSpalten = size(lhsb,2)
    if (l+u+1_i4    /= nZeilen ) stop 'solve_linear_equations_1_dp: Given banded matrix must have l+u+1 rows.'
    if (size(rhs,1) /= nSpalten) stop 'solve_linear_equations_1_dp: right hand side must have same size as left hand side.'
    ! internal arrays
    allocate(ilhsb(nZeilen + l,nSpalten), irhs(nSpalten))
    ilhsb = 0.0_dp

    ilhsb(1+l:nZeilen + l,:) = lhsb
    irhs                     = rhs

    if (present(condition)) then
       icondition = condition
    else
       icondition = .true.
    endif

    if (icondition) then
       ! Condition of matrix
       allocate(scale_cols(nSpalten))
       ! Condition columns
       scale_cols(:) = maxval(abs(ilhsb(:,:)),1)
       where (scale_cols(:) < tiny(1.0_dp)) scale_cols(:) = 1.0_dp
       scale_cols(:) = 1.0_dp / scale_cols(:)
       forall(ii=1:nSpalten) ilhsb(:,ii) = ilhsb(:,ii) * scale_cols(ii)
    endif

    ! solve linear system of equations
    allocate(ipiv(nSpalten))
    call dgbsv(nSpalten, l, u, 1, ilhsb, nZeilen+l, ipiv, irhs, nSpalten, info)
    if (info /= 0) stop 'solve_linear_equations_band_1_dp: Solving of linear system did not work.'

#ifndef __PYTHON__
    if (.not. allocated(solve_linear_equations_band_1_dp)) allocate(solve_linear_equations_band_1_dp(nSpalten))
#endif
    solve_linear_equations_band_1_dp = irhs

    if (icondition) then
       ! rescale result
       solve_linear_equations_band_1_dp(:) = solve_linear_equations_band_1_dp(:) * scale_cols(:)

       deallocate(scale_cols)
    endif

    deallocate(ilhsb, irhs)
    deallocate(ipiv)

  END FUNCTION solve_linear_equations_band_1_dp

  FUNCTION solve_linear_equations_band_1_sp(lhsb, rhs, l, u, condition)

    IMPLICIT NONE

    REAL(sp), DIMENSION(:,:), INTENT(IN) :: lhsb !banded form of the lhs
    REAL(sp), DIMENSION(:),   INTENT(IN) :: rhs
    INTEGER(i4),              INTENT(IN) :: l, u
    LOGICAL,  OPTIONAL,       INTENT(IN) :: condition
#ifndef __PYTHON__
    REAL(sp), DIMENSION(:), allocatable  :: solve_linear_equations_band_1_sp
#else
    REAL(sp), DIMENSION(size(rhs,1)) :: solve_linear_equations_band_1_sp
#endif

#ifndef __PYTHON__
    if (.not. allocated(solve_linear_equations_band_1_sp)) allocate(solve_linear_equations_band_1_sp(size(rhs,1)))
#endif
    solve_linear_equations_band_1_sp = real(solve_linear_equations_band_1_dp(real(lhsb,dp), real(rhs,dp), l, u, condition), sp)

  END FUNCTION solve_linear_equations_band_1_sp

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

  ! From Numerical Recipes in F77 book
  ! Solves A*X=B for a vector X, where A is specified by the arrays u, w, v as returned by
  ! svdcmp. m and n are the logical dimensions of a, and will be equal for square matrices. mp
  ! and np are the physical dimensions of a. b(1:m) is the input right-handside. x(1:n) is
  ! the output solution vector. No input quantities are destroyed, so the routine may be called
  ! sequentially with different bs.
  FUNCTION svdksb_dp(u,w,v,b)

    IMPLICIT NONE

    REAL(dp), DIMENSION(:,:), INTENT(IN) :: u,v
    REAL(dp), DIMENSION(:),   INTENT(IN) :: w,b
    REAL(dp), DIMENSION(size(u,2))       :: svdksb_dp

    REAL(dp), DIMENSION(size(u,2)) :: tmp
    REAL(dp), DIMENSION(size(w))   :: wtmp

    wtmp = w
    where (abs(w) < tiny(1.0_dp)) wtmp = 1.0_dp
    tmp = matmul(b,u) / wtmp
    where (abs(w) < tiny(1.0_dp)) tmp = 0.0_dp
    svdksb_dp = matmul(v,tmp)

  END FUNCTION svdksb_dp

  FUNCTION svdksb_sp(u,w,v,b)

    IMPLICIT NONE

    REAL(sp), DIMENSION(:,:), INTENT(IN) :: u,v
    REAL(sp), DIMENSION(:),   INTENT(IN) :: w,b
    REAL(sp), DIMENSION(size(u,2))       :: svdksb_sp

    REAL(sp), DIMENSION(size(u,2)) :: tmp
    REAL(sp), DIMENSION(size(w))   :: wtmp

    wtmp = w
    where (abs(w) < tiny(1.0_sp)) wtmp = 1.0_sp
    tmp = matmul(b,u) / wtmp
    where (abs(w) < tiny(1.0_sp)) tmp = 0.0_sp
    svdksb_sp = matmul(v,tmp)

  END FUNCTION svdksb_sp

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

END MODULE mo_linear_algebra


program test
use iso_fortran_env
use mod_mpifw
implicit none

integer(4) :: i, a(3) , b(3)

call init_mpi()

    a = [( this_proc*i , i=1,3)]

    write(*,'(*(g0,1x))') this_proc,")", a

    call sync_mpi()
    if(this_proc==0) write(*,*) "=================="
    call sync_mpi()

    write(*,'(*(g0,1x))') this_proc,")",reduce_mpi(a, 0, "sum")

    call sync_mpi()
    if(this_proc==0) write(*,*) "=================="
    call sync_mpi()

    write(*,'(*(g0,1x))') this_proc,")",allreduce_mpi(a, "sum")

call finish_mpi()
end program


program module_example
use constants
implicit none

   real :: x, ePowerx, area, radius
   x = 2.0
   radius = 7.0
   ePowerx = e ** x
   area = pi * radius**2

   call show_consts()

   print*, "e raised to the power of 2.0 = ", ePowerx
   print*, "Area of a circle with radius 7.0 = ", area

end program module_example