module models
use math
implicit none
contains
    subroutine parrat_amplitude(q, sld, sigma, thickness, NLayers, Nq, refl)
        double precision, intent(in), dimension(Nq) :: q
        complex*16, intent(in), dimension(NLayers) :: sld
        double precision, intent(in), dimension(NLayers) :: sigma, thickness
        integer, intent(in):: NLayers, Nq
        complex*16, intent(out), dimension(Nq) :: refl

        integer :: iq, ir

        double precision :: k0, k02
        complex*16 :: ksub, kj, knext, rnext, p2, refl_val

        !$omp parallel
        !$omp do
        do iq=1,Nq
            k0 = q(iq)/2d0
            k02= k0**2

            ksub = cdsqrt(k02 - 4d0*pi*sld(1))
            kj = cdsqrt(k02 - 4d0*pi*sld(2))
            refl_val = (kj-ksub)/(kj+ksub) * cdexp(-2d0*ksub*kj*sigma(1)**2)
            do ir=2, NLayers-1
                knext = cdsqrt(k02 - 4d0*pi*sld(ir+1))
                rnext = (knext-kj)/(knext+kj)*cdexp(-2d0*knext*kj*sigma(ir)**2)
                p2 = cdexp(2d0*ci*thickness(ir)*kj)
                refl_val = (rnext + refl_val*p2) / ( 1 + rnext*refl_val*p2)
                kj = knext
            end do
            refl(iq) = refl_val
        end do
        !$omp end do
        !$omp end parallel
    end subroutine parrat_amplitude

    subroutine parrat(q, sld, sigma, thickness, NLayers, Nq, refl)
        double precision, intent(in), dimension(Nq) :: q
        complex*16, intent(in), dimension(NLayers) :: sld
        double precision, intent(in), dimension(NLayers) :: sigma, thickness
        integer, intent(in):: NLayers, Nq
        double precision, intent(out), dimension(Nq) :: refl

        complex*16, dimension(Nq) :: refl_ampl

        call parrat_amplitude(q, sld, sigma, thickness, NLayers, Nq, refl_ampl)
        refl = zabs(refl_ampl)**2
    end subroutine parrat

    subroutine add_layer_to_sld(x, x0, sld_pre, sld_after, rough,&
                                Nx, roughsld_in, roughsld_out)
        double precision, dimension(Nx), intent(in) :: x
        double precision, intent(in) :: x0
        complex*16, intent(in) :: sld_pre, sld_after
        double precision, intent(in) :: rough
        integer, intent(in) :: Nx
        complex*16, dimension(Nx), intent(in) :: roughsld_in
        complex*16, dimension(Nx), intent(out) :: roughsld_out

        complex*16 :: diffsld
        integer :: j
        diffsld = sld_after - sld_pre
        roughsld_out = roughsld_in
        if (rough == 0d0) then
            do j=1, Nx
                if (x(j) < x0) then
                    cycle
                else
                    roughsld_out(j) = roughsld_in(j) + diffsld
                end if
            end do
        else
            do j=1, Nx
                roughsld_out(j) = roughsld_in(j) +&
                        diffsld * 0.5d0*(1d0+erf((x(j)-x0)/(sq2*rough)))
            end do
        end if

    end subroutine add_layer_to_sld

    subroutine roughsld_thick_layers(x, complex_sld, sigma, thickness, &
            Nx, Nthickness, rough_sld)
        double precision, intent(in), dimension(Nx) :: x
        complex*16, intent(in), dimension(Nthickness) :: complex_sld
        double precision, intent(in), dimension(Nthickness) :: thickness,&
                                                               sigma
        integer, intent(in) :: Nx, Nthickness
        complex*16, intent(out), dimension(Nx) :: rough_sld

        integer :: i,j
        complex*16 :: diffsld
        double precision :: rough
        double precision :: x0, xlast

        !substrate
        rough_sld = complex_sld(1)
        x0 = x(1)+thickness(1)
        !sequentially go layer by layer
        do i=1, Nthickness-1
            call add_layer_to_sld(x, x0, complex_sld(i), complex_sld(i+1),&
                            sigma(i),&
                            Nx, rough_sld, rough_sld)
            x0 = x0 + thickness(i+1)
        end do
    end subroutine roughsld_thick_layers

    subroutine sld_and_rough_from_thicknesses(thickness, sld, sigma, x,&
                        Nx, Nthickness, sld_on_x, sigma_on_x)
        double precision, dimension(Nthickness), intent(in) :: thickness, sld, &
                                                            sigma
        double precision, dimension(Nx), intent(in) :: x
        integer, intent(in) :: Nx, Nthickness
        double precision, dimension(Nx), intent(out) :: sld_on_x, sigma_on_x

        integer :: i,j
        double precision :: z0, zlast

        !substrate
        do j=1, Nx
            if (x(j) < 0d0) then
                sld_on_x(j) = sld(1)
                sigma_on_x(j) = sigma(1)
            else
                exit
            end if
        end do

        !layer by layer
        z0 = thickness(2)
        zlast = 0d0
        do i=2, Nthickness
            do j=1, Nx
                if (x(j) < zlast) then
                    cycle
                else if (x(j) < z0) then
                    sld_on_x(j) = sld(i)
                    sigma_on_x(j) = sigma(i)
                else
                    exit
                end if
            end do
            zlast = z0
            z0 = z0 + thickness(i+1)
        end do
    end subroutine sld_and_rough_from_thicknesses

    subroutine get_k(sld, k0, k)
        complex*16, intent(in) :: sld
        double precision, intent(in) :: k0
        complex*16, intent(out) :: k

        k = cdsqrt(k0**2 - 4d0*pi*sld)
    end subroutine get_k

    subroutine scattering_matrix_fresnel(k1, k2, sigma, S)
        complex*16, intent(in) :: k1, k2
        double precision, intent(in) :: sigma
        !f2py double precision, intent(in), optional:: sigma=0
        complex*16, dimension(2,2), intent(out) :: S

        complex*16 :: r, t

        r = (k1-k2) / (k1+k2) * cdexp(-2*sigma**2*k1*k2)
        t = 2*cdsqrt(k1*k2) / (k1+k2) * cdexp(5d-1*sigma**2*(k1-k2)**2)
        S(1,1) = r
        S(1,2) = t
        S(2,1) = t
        S(2,2) = -r
    end subroutine scattering_matrix_fresnel

    subroutine scattering_matrix_translation(k1, thickness, S)
        complex*16, intent(in) :: k1
        double precision, intent(in) :: thickness
        complex*16, dimension(2,2), intent(out) :: S

        S(1,1) = 0d0
        S(1,2) = cdexp(-ci*thickness*k1)
        S(2,1) = cdexp(-ci*thickness*k1)
        S(2,2) = 0d0
    end subroutine scattering_matrix_translation

    subroutine connect_scattering_matrices(S1, S2, S)
        complex*16, dimension(2,2), intent(in) :: S1, S2
        complex*16, dimension(2,2), intent(out) :: S

        complex*16 :: nominator
        nominator = 1d0/(1d0 - S1(2,2)*S2(1,1))
        S(1,1) = S1(1,1) + S1(1,2)*S2(1,1)*S1(2,1)*nominator
        S(2,2) = S2(2,2) + S2(2,1)*S1(2,2)*S2(1,2)*nominator
        S(2,1) = S1(2,1)*S2(2,1)*nominator
        S(1,2) = S1(1,2)*S2(1,2)*nominator
    end subroutine connect_scattering_matrices

    subroutine scattering_matrix_algorithm(q, sld, thickness, roughness, &
                                           NLayers, S)
        double precision, intent(in) :: q
        complex*16, dimension(NLayers), intent(in) :: sld
        double precision, dimension(NLayers), intent(in) :: thickness,roughness
        integer, intent(in):: NLayers
        complex*16, dimension(2, 2), intent(out) :: S

        integer :: ir
        double precision :: k0, k02
        complex*16 :: ksub, kj, knext

        complex*16, dimension(2,2) :: Snext, Slast

        if (NLayers  == 0) then
            print *, "Error: Pass non empty sld array to scattering matrix algorithm."
            return
        end if

        k0 = q/2d0
        k02= k0**2
        ksub = cdsqrt(k02 - 4d0*pi*sld(1))

        if (NLayers  == 1) then
            call scattering_matrix_fresnel(ksub, cdsqrt(k02+0*ci), roughness(1), S)
            return
        end if

        !Nlayers > 1:
        kj = cdsqrt(k02 - 4d0*pi*sld(2))
        call scattering_matrix_fresnel(ksub, kj, roughness(1), S)

        do ir=2, NLayers-1
            ! translate and connect
            call scattering_matrix_translation(kj, thickness(ir), Snext)
            call connect_scattering_matrices(S, Snext, S)

            !calc next and connect
            knext = cdsqrt(k02 - 4d0*pi*sld(ir+1))
            call scattering_matrix_fresnel(kj, knext, roughness(ir), Snext)
            call connect_scattering_matrices(S, Snext, S)
            kj = knext
        end do
    end subroutine scattering_matrix_algorithm

    recursive subroutine recursive_scatt_adding(S1, N, S)
        complex*16, dimension(2,2), intent(in) :: S1
        integer, intent(in) :: N
        complex*16, dimension(2,2), intent(out) :: S

        complex*16, dimension(2,2) :: Shelp

        if (N > 1) then
            call connect_scattering_matrices(S1, S1, Shelp)
            if(mod(N,2) == 0) then
                call recursive_scatt_adding(Shelp, N/2, S)
            else
                call recursive_scatt_adding(Shelp, (N-1)/2, S)
                call connect_scattering_matrices(S1, S, S)
            end if
        else
            S = S1
        end if
    end subroutine

    subroutine scattering_matrix_periodic_algorithm(q, &
            sld_sub, sld_per, sld_end,&
            thickness_sub, thickness_per, thickness_end,&
            roughness_sub, roughness_per, roughness_end,&
            Nperiods, &
            NLayers_sub, Nlayers_per, Nlayers_end, S)

        double precision, intent(in) :: q
        complex*16, dimension(NLayers_sub), intent(in) :: sld_sub
        complex*16, dimension(NLayers_per), intent(in) :: sld_per
        complex*16, dimension(NLayers_end), intent(in) :: sld_end
        double precision, dimension(NLayers_sub), intent(in) :: thickness_sub,&
                                                                roughness_sub
        double precision, dimension(NLayers_per), intent(in) :: thickness_per,&
                                                                roughness_per
        double precision, dimension(NLayers_end), intent(in) :: thickness_end,&
                                                                roughness_end
        integer, intent(in) :: Nperiods
        integer, intent(in):: NLayers_sub, Nlayers_per, Nlayers_end
        complex*16, dimension(2, 2), intent(out) :: S

        integer :: iperiod, ir
        double precision :: k0, k02
        complex*16 :: ksub1, ksub0, kper1, kper0, kend1, kj, knext

        complex*16, dimension(2,2) :: S_sub, S_per, S_con_per, S_end, S_help,&
                                      S_help2

        k0 = q/2d0
        k02= k0**2
        ksub1 = cdsqrt(k02 - 4d0*pi*sld_sub(1))
        ksub0 = cdsqrt(k02 - 4d0*pi*sld_sub(NLayers_sub))
        kper1 = cdsqrt(k02 - 4d0*pi*sld_per(1))
        kper0 = cdsqrt(k02 - 4d0*pi*sld_per(NLayers_per))
        kend1 = cdsqrt(k02 - 4d0*pi*sld_end(1))
        if (Nlayers_sub == 0 .OR. NLayers_per == 0 .OR. Nlayers_end == 0) then
            print *, "Error: Substrate, Periodic or End SLD is empty. Check it!"
            return
        end if

        ! calc Scattering matrix for substrate
        if (NLayers_sub  == 1) then
            ! just connect substrate to periodic layers
            call scattering_matrix_fresnel(ksub1, kper1,&
                                           roughness_sub(1), S_sub)
        else
            ! first calc scattering matrix for substrate
            call scattering_matrix_algorithm(q, sld_sub, thickness_sub,&
                                             roughness_sub, &
                                             NLayers_sub, S_sub)
            ! do translation of last layer in substrate
            call scattering_matrix_translation(ksub0,&
                                               thickness_sub(Nlayers_sub),&
                                               S_help)
            call connect_scattering_matrices(S_sub, S_help, S_sub)

            ! connect with first layer of periodic layer
            call scattering_matrix_fresnel(ksub0, kper1,&
                                            roughness_sub(NLayers_sub), S_help)
            call connect_scattering_matrices(S_sub, S_help, S_sub)
        end if

        ! calc scattering matrix for periodic cell
        !first translation of first element
        call scattering_matrix_translation(kper1, thickness_per(1), S_per)
        if (Nlayers_per > 1) then
            call scattering_matrix_algorithm(q, sld_per, thickness_per,&
                                             roughness_per, &
                                             NLayers_per, S_help)
            call connect_scattering_matrices(S_per, S_help, S_per)

            ! do translation of last layer in periodic layer
            call scattering_matrix_translation(kper0, &
                                               thickness_per(Nlayers_per),&
                                               S_help)
            call connect_scattering_matrices(S_per, S_help, S_per)

            !calculate matrix to connect two periodic layers
            call scattering_matrix_fresnel(kper0, kper1, &
                                         roughness_per(Nlayers_per), S_con_per)
        else
            ! for Nlayers == 1, connecting matrix aquivalent to 0 translation.
            call scattering_matrix_translation(kper1, 0d0, S_con_per)
        end if

        ! calculate scattering matrix for end
        ! first connect last element of periodic layer to first layer of end
        call scattering_matrix_fresnel(kper0, kend1,&
                                        roughness_per(Nlayers_per), S_end)
        if (Nlayers_end > 1) then
            ! do translation of first layer in last layer
            call scattering_matrix_translation(kend1, &
                                               thickness_end(1),&
                                               S_help)
            call connect_scattering_matrices(S_end, S_help, S_end)

            call scattering_matrix_algorithm(q, sld_end, thickness_end,&
                                             roughness_end, &
                                             NLayers_end, S_help)
            call connect_scattering_matrices(S_end, S_help, S_end)
        end if

        ! now connect everything
        call connect_scattering_matrices(S_sub, S_per, S)

        call connect_scattering_matrices(S_con_per, S_per, S_help)
        if (Nperiods > 1) then
            call recursive_scatt_adding(S_help, Nperiods-1, S_help2)
            call connect_scattering_matrices(S, S_help2, S)
        end if
        call connect_scattering_matrices(S, S_end, S)
    end subroutine scattering_matrix_periodic_algorithm

    subroutine periodic_model(q, sld_sub, sld_per, sld_end,&
                                thickness_sub, thickness_per, thickness_end,&
                                roughness_sub, roughness_per, roughness_end,&
                                Nperiods,&
                                Nq, NLayers_sub, Nlayers_per, Nlayers_end,&
                                refl)
        double precision, intent(in), dimension(Nq) :: q
        complex*16, dimension(NLayers_sub), intent(in) :: sld_sub
        complex*16, dimension(NLayers_per), intent(in) :: sld_per
        complex*16, dimension(NLayers_end), intent(in) :: sld_end
        double precision, dimension(NLayers_sub), intent(in) :: thickness_sub,&
                                                                roughness_sub
        double precision, dimension(NLayers_per), intent(in) :: thickness_per,&
                                                                roughness_per
        double precision, dimension(NLayers_end), intent(in) :: thickness_end,&
                                                                roughness_end
        integer, intent(in) :: Nperiods
        integer, intent(in):: Nq, NLayers_sub, Nlayers_per, Nlayers_end
        double precision, intent(out), dimension(Nq) :: refl

        complex*16, dimension(2,2) :: S
        integer :: iq
        !$omp parallel private(S)
        !$omp do
        do iq=1,Nq
            call scattering_matrix_periodic_algorithm(q(iq), &
                                sld_sub, sld_per, sld_end,&
                                thickness_sub, thickness_per, thickness_end,&
                                roughness_sub, roughness_per, roughness_end,&
                                Nperiods, &
                                NLayers_sub, Nlayers_per, Nlayers_end, S)
            refl(iq) = abs(S(2, 2))**2
        end do
        !$omp end do
        !$omp end parallel
    end subroutine periodic_model

    subroutine add_layers_shifted(x, sld_profile1, sld_profile2, &
                                  x0_profile2, Nx, sld_res)
            double precision, dimension(Nx), intent(in) :: x
            complex*16, dimension(Nx), intent(in) :: sld_profile1, sld_profile2
            double precision, intent(in) :: x0_profile2
            integer, intent(in) :: Nx
            complex*16, dimension(Nx), intent(out) :: sld_res

            integer :: ix, ix0
            ix0 = 1
            do ix=1, Nx
                if(x(ix) < x0_profile2) then
                    sld_res(ix) = sld_profile1(ix)
                    ix0 = ix0 + 1
                else
                    sld_res(ix) = sld_profile2(ix-ix0+1) !- sld_profile2(1)
                end if
            end do
    end subroutine add_layers_shifted

    subroutine periodic_sld(x,&
                        sld_sub, sld_per, sld_end,&
                        thickness_sub, thickness_per, thickness_end,&
                        roughness_sub, roughness_per, roughness_end,&
                        Nperiods,&
                        Nx, NLayers_sub, Nlayers_per, Nlayers_end,&
                        sld)
        double precision, intent(in), dimension(Nx) :: x
        complex*16, dimension(NLayers_sub), intent(in) :: sld_sub
        complex*16, dimension(NLayers_per), intent(in) :: sld_per
        complex*16, dimension(NLayers_end), intent(in) :: sld_end
        double precision, dimension(NLayers_sub), intent(in) :: thickness_sub,&
                                                                roughness_sub
        double precision, dimension(NLayers_per), intent(in) :: thickness_per,&
                                                                roughness_per
        double precision, dimension(NLayers_end), intent(in) :: thickness_end,&
                                                                roughness_end
        integer, intent(in) :: Nperiods
        integer, intent(in):: Nx, NLayers_sub, Nlayers_per, Nlayers_end
        complex*16, intent(out), dimension(Nx) :: sld

        integer :: i, iperiod
        complex*16, dimension(NLayers_sub + Nperiods*NLayers_per+ Nlayers_end)&
                                 :: combined_sld
        double precision, dimension(NLayers_sub + Nperiods*NLayers_per+ Nlayers_end)&
                                 :: combined_roughness, combined_thickness

        do i=1, Nlayers_sub
            combined_sld(i) = sld_sub(i)
            combined_roughness(i) = roughness_sub(i)
            combined_thickness(i) = thickness_sub(i)
        end do

        do iperiod=1, Nperiods
            do i=1, Nlayers_per
                combined_sld(Nlayers_sub + (iperiod-1)*Nlayers_per + i) =&
                             sld_per(i)
                combined_roughness(Nlayers_sub + (iperiod-1)*Nlayers_per + i) =&
                             roughness_per(i)
                combined_thickness(Nlayers_sub + (iperiod-1)*Nlayers_per + i) =&
                             thickness_per(i)
            end do
        end do

        do i=1, Nlayers_end
            combined_sld(Nlayers_sub + Nperiods*Nlayers_per + i) =&
                              sld_end(i)
            combined_roughness(Nlayers_sub + Nperiods*Nlayers_per + i) =&
                              roughness_end(i)
            combined_thickness(Nlayers_sub + Nperiods*Nlayers_per + i) =&
                              thickness_end(i)
        end do

        call roughsld_thick_layers(x, combined_sld, combined_roughness,&
                    combined_thickness, &
                    Nx, NLayers_sub + Nperiods*NLayers_per+Nlayers_end, sld)
    end subroutine periodic_sld

    subroutine coreshell_sphere_area_fraction(x, x0,&
                                    density, core_radius, shell_thickness,&
                                    Nx,&
                                    area_core, area_shell)
    double precision, intent(in), dimension(Nx) :: x
    double precision, intent(in) :: x0, density, core_radius, shell_thickness
    integer, intent(in) :: Nx
    double precision, intent(out), dimension(Nx) :: area_core, area_shell

    double precision :: particle_size, xshift, constshift
    double precision :: area_core_mod, area_shell_mod
    integer :: i

    particle_size = core_radius + shell_thickness

    constshift = density*(1d0 - (core_radius/particle_size)**2)
    area_core_mod = density*(core_radius/particle_size)**2
    area_shell_mod = density
    do i=1, Nx
        xshift = x(i) - particle_size - x0
        if (xshift < -particle_size) then
            area_core(i) = 0d0
            area_shell(i) = 0d0
        else if (xshift < -core_radius) then
            area_core(i) = 0d0
            area_shell(i) = (1d0- (xshift/particle_size)**2 )*area_shell_mod
        else if (xshift  < core_radius) then
            area_core(i) = (1d0- (xshift/core_radius)**2 )*area_core_mod
            area_shell(i) = constshift
        else if (xshift < particle_size) then
            area_core(i) = 0d0
            area_shell(i) = (1d0- (xshift/particle_size)**2 )*area_shell_mod
        else
            area_core(i) = 0d0
            area_shell(i) = 0d0
        end if
    end do
    end subroutine coreshell_sphere_area_fraction

    subroutine coreshell_sphere_sld(density, core_radius, shell_thickness,&
                                    sld_core, sld_shell, Nx,&
                                    sldmodel)
    double precision, intent(in) :: density, core_radius, shell_thickness
    complex*16, intent(in) :: sld_core, sld_shell
    integer, intent(in) :: Nx
    complex*16, intent(out), dimension(Nx) :: sldmodel

    double precision :: particle_size
    double precision :: xshift, sld_resolution
    double precision :: constshift
    complex*16 :: sld_core_mod, sld_shell_mod
    integer :: i

    particle_size = core_radius + shell_thickness
    sld_resolution = 2*particle_size/Nx

    constshift = density*(1d0 - (core_radius/particle_size)**2)*sld_shell
    sld_core_mod = density*(core_radius/particle_size)**2*sld_core
    sld_shell_mod = density*sld_shell
    do i=1, Nx
        xshift = (i-1)*sld_resolution - particle_size
        if (xshift < -particle_size) then
            sldmodel(i) = 0d0
        else if (xshift < -core_radius) then
            sldmodel(i) = (1d0- (xshift/particle_size)**2 )*sld_shell_mod
        else if (xshift  < core_radius) then
            sldmodel(i) = (1d0- (xshift/core_radius)**2 )*sld_core_mod + constshift
        else if (xshift < particle_size) then
            sldmodel(i) = (1d0- (xshift/particle_size)**2 )*sld_shell_mod
        else
            sldmodel(i) = 0d0
        end if
    end do
    end subroutine coreshell_sphere_sld

    subroutine N_layers_coated_spheres_part_dist_2(z, z0_shifts, packing_densities,&
                     Rcore, sigRcore, dshell, SLDc, SLDs, SLDbg, result_sld,&
                     Nz, Nlayers, Nsigs, Npts)
        implicit none
        integer, intent(in) :: Nz, Nlayers
        double precision, intent(in), dimension(Nz) :: z
        double precision, intent(in), dimension(Nlayers) :: z0_shifts, packing_densities
        double precision, intent(in) :: Rcore, sigRcore, dshell, SLDc, SLDs, SLDbg
        integer,intent(in) :: Nsigs, Npts
    !f2py   integer, optional, intent(in):: Nsigs=5
    !f2py   integer, optional, intent(in):: Npts=200
        double precision, intent(out), dimension(Nz) :: result_sld

        double precision, parameter :: pi = 3.141592653589793
        double precision, dimension(Nz) :: core_area, shell_area

        integer :: i, iz, iLayer
        double precision :: dSLDc, dSLDs
        double precision :: Rd, Rparticle, area_prefactor, tessel_z, last_z0
        double precision :: zshift
        double precision, dimension(Npts) :: hcore, hshell

        double precision :: Rstd, Rcore_min, Rcore_max, Rcore_steps
        double precision :: Rcore_i, Rd_i
        double precision, dimension(Npts) :: p_log

        ! Initialize core and shell areas:
        do i=1, Nz
            core_area(i) = 0d0
            shell_area(i) = 0d0
        end do

        dSLDc = SLDc - SLDbg
        dSLDs = SLDs - SLDbg

        ! Initialize integration parameters
        Rstd = dsqrt(dexp(2*dlog(Rcore) + sigRcore**2)*(dexp(sigRcore**2)-1))
        Rcore_min = Rcore - Nsigs*Rstd
        Rcore_max = Rcore + Nsigs*Rstd
        Rcore_steps = (Rcore_max-Rcore_min)/(Npts-1)

        do i=1, Npts
            Rcore_i = Rcore_min + (i-1)*Rcore_steps
            call lognormal(Rcore_i, Rcore, sigRcore, p_log(i))
        end do

        Rd = Rcore + 0.5d0*dshell
        Rparticle = Rcore + dshell
        area_prefactor = pi/(2*dsqrt(3d0))
        tessel_z = 2d0*dsqrt(6d0)*Rd/3d0

        last_z0 = Rparticle
        do iLayer=1, Nlayers
            last_z0 = last_z0 + z0_shifts(iLayer)
            if (iLayer > 1) last_z0 = last_z0 + tessel_z
            do iz=1, Nz
                zshift = z(iz) - last_z0
                do i=1, Npts
                    Rcore_i = Rcore_min + (i-1)*Rcore_steps
                    Rparticle = Rcore_i + dshell
                    if (zshift < -Rparticle) then
                        hshell(i) = 0d0
                        hcore(i) = 0d0
                    else if (zshift < -Rcore_i) then
                        hshell(i) = packing_densities(iLayer)*&
                                (Rparticle**2 - zshift**2)/Rcore_i**2 * p_log(i)
                        hcore(i) = 0d0
                    else if (zshift  < Rcore_i) then
                        hshell(i) = packing_densities(iLayer)*&
                                    (2*Rcore_i*dshell + dshell**2)/Rcore_i**2 * p_log(i)
                        hcore(i) = packing_densities(iLayer)*&
                                    (Rcore_i**2 - zshift**2)/Rcore_i**2 * p_log(i)
                    else if (zshift < Rparticle) then
                        hshell(i) = packing_densities(iLayer)*&
                                (Rparticle**2 - zshift**2)/Rcore_i**2 * p_log(i)
                        hcore(i) = 0d0
                    else
                        hshell(i) = 0d0
                        hcore(i) = 0d0
                    end if
                end do
                core_area(iz) = core_area(iz) + trapz_uniform(hcore, Rcore_steps, Npts)
                shell_area(iz) = shell_area(iz) + trapz_uniform(hshell, Rcore_steps, Npts)
            end do
        end do

        do iz=1, Nz
            result_sld(iz) = SLDbg + core_area(iz)*dSLDc + shell_area(iz)*dSLDs
        end do
    end subroutine N_layers_coated_spheres_part_dist_2

end module models


! fortran_free_source
!
!  This module is part of Perfcode, written by Bradley J Eck
!
module budget
implicit none
contains
!
!	1. Subroutine WATER_BUDGET
!
!========================================================================
!   \\\\\\\\\\  B E G I N     S U B R O U T I N E    //////////
!   //////////     W A T E R _ B U D G E T           \\\\\\\\\\\
!=========================================================================
subroutine WATER_BUDGET(     old_volume, &
                             pfc_volume, &
                         surface_volume, &
                            rain_volume, &
                       north_out_volume, &
                       south_out_volume, &
                        east_out_volume, &
                        west_out_volume, &
                        net_flow_volume, &
                     storage_chg_volume, &
                          volume_error , &
                    volume_error_fraction       )
!   Computes a global water balance at each time step.
use shared, only: imax, jmax, area, por, b_pfc, h_new, rain, n, dt
use boundcond, only: F_Qout_bound
use pfc2Dsubs, only: CALC_Qx
implicit none
! Arguments
real, intent(in)  :: old_volume
real, intent(out) :: pfc_volume, surface_volume, rain_volume
real, intent(out) :: north_out_volume, south_out_volume
real, intent(out) ::  east_out_volume, west_out_volume
real, intent(out) :: net_flow_volume,  storage_chg_volume
real, intent(out) :: volume_error, volume_error_fraction
! Internal variables
integer :: i, j, v
real :: hp, hs
real, dimension(imax, jmax) :: vol  !volume array
!-----------------------------------------------------------------------
vol(:,:) = 0.0
! WATER BALANCE
! Volume of water in the pfc
do j = 1, jmax
    do i = 1, imax
        hp = min( h_new(i, j), b_pfc(i, j) )
        vol(i, j) = hp * area(i,j) * por(i, j)
    end do
end do

pfc_volume = sum( vol(:,:) )

! Volume of water on the surface
vol(:,:) = 0.0

do j = 1, jmax
    do i = 1, imax
        hs = max( h_new(i, j) - b_pfc(i, j), 0.0 )
        vol(i, j) = hs * area(i,j)
    end do
end do

surface_volume = sum( vol(:,:) )

! Rainfall
rain_volume = rain(n) * dt * sum( area(:,:) )

! Outflow
vol(:,:) = 0.
! North & South (including all of corner cells)
do j = 1, jmax, jmax-1
    do i = 1, imax

        vol(i,j) = F_Qout_bound(i, j) * dt

    end do
end do

south_out_volume = sum( vol(:,1)    )
north_out_volume = sum( vol(:,jmax) )

! East & West
do j = 2, jmax-1
    do i = 1, imax, imax-1

        vol(i,j) = F_Qout_bound(i, j) * dt

    end do
end do

west_out_volume = sum( vol( 1   , 2:jmax-1 ) )
east_out_volume = sum( vol( imax, 2:jmax-1 ) )

! Net flow
net_flow_volume = rain_volume + north_out_volume + south_out_volume &
                              +  east_out_volume +  west_out_volume

! Storage Change
storage_chg_volume = pfc_volume + surface_volume - old_volume

! Error
volume_error = net_flow_volume - storage_chg_volume
volume_error_fraction = volume_error / storage_chg_volume

!-----------------------------------------------------------------------
end subroutine water_budget
!=======================================================================
!  \\\\\\\\\\   E N D        S U B R O U T I N E    //////////
!  //////////     W A T E R _ B U D G E T           \\\\\\\\\\\
!========================================================================

end module


!---------------------------------------------------!
! Copyright (c) 2016 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
!-------10--------20--------30--------40--------50--------60--------70--------80--------90
subroutine energy_calc(Eelec,Eelemag,Etot)
  use global_variables_ms
  implicit none
  real(8),intent(out) :: Eelec,Eelemag,Etot
  real(8) :: Eelec_l,Et,Bt
  integer :: ix,im,ikz,ikr

  Eelec_l = 0d0
  do im = Mx_s,Mx_e
    do ikz = -NKz,NKz
      do ikr = 1,NKr
        Eelec_l = Eelec_l + deps(ikr,ikz,im)*abs(zCt(2,ikr,ikz,im))**2*kr(ikr)
      end do
    end do
  end do
  Eelec_l = Eelec_l * 2d0/((2d0*pi)**3)*(2d0*pi*dkr*dkz)
  call MPI_ALLREDUCE(Eelec_l,Eelec,1,MPI_REAL8,MPI_SUM,MPI_COMM_WORLD,ierr)

  Eelemag = 0d0
  do ix = Nx_L+1,Nx_R-1
    Et = -0.5d0*(Az_new(ix)-Az_old(ix))/dt
    Bt = -0.5d0*(Az(ix+1)-Az(ix-1))*c_light/Hx
    Eelemag = Eelemag + (Et**2+Bt**2)
  end do

  Etot = Eelec + Eelemag
!!== Unit should be consistent between Eelec and Eelemag ==!!

end subroutine energy_calc


module dfpmin_mod

Contains

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE dfpmin(n,p,gtol,tolx, stpmx,iter,fret, iprint, dfunc)
!.......................................................................
      implicit none
      integer,                        intent( in    ) :: n
      double precision, dimension(n), intent( inout ) :: p(n)
      double precision,               intent( in    ) :: gtol, tolx
      double precision,               intent( in    ) :: stpmx
      integer,                        intent(   out ) :: iter
      double precision,               intent(   out ) :: fret
      integer,                        intent( in    ) :: iprint
      interface
         subroutine dfunc(n, p, g, fret)
         implicit none
         integer,                        intent( in    ) :: n
         double precision, dimension(n), intent( in    ) :: p
         double precision, dimension(n), intent(   out ) :: g
         double precision,               intent(   out ) :: fret
         end subroutine dfunc
      end interface
      !...
      integer, parameter :: ITMAX=999999
      INTEGER i,j,its
      LOGICAL check
      double precision, dimension(:,:), allocatable :: hessin
      double precision, dimension(:), allocatable :: g, dg, hdg, pnew, xi
      double precision :: den,fac,fad,fae,fp,stpmax,sum0,sumdg,sumxi,temp,test
      double precision :: tmp, testx, testg,EPS

      allocate(hessin(n,n))
      allocate(g(n))
      allocate(dg(n))
      allocate(hdg(n))
      allocate(pnew(n))
      allocate(xi(n))
      EPS=TOLX/4.d0
      call dfunc(n, p, g, fp)
      sum0=0.d0
      hessin(1:n, 1:n) = 0.d0
      do i=1,n
         hessin(i,i)=1.D0
         xi(i)=-g(i)
         sum0=sum0+p(i)**2
      enddo
      stpmax=STPMX*dmax1(dsqrt(sum0),dble(n))
      do 27 its=1,ITMAX
        iter=its
        call lnsrch(n,p,fp,g,xi,pnew,fret,stpmax,tolx, check, dfunc)
        fp=fret
        !Here is my attempt to constrain the oxygen positions JPH
        !pnew(n/3+1:n) = p(n/3+1:n)
        xi(1:n) = pnew(1:n) - p(1:n)
        p(1:n) = pnew(1:n)
        test=0.d0
        do 14 i=1,n/3
          temp=dabs(xi(i))/dmax1(dabs(p(i)),1.d0)
        !JPH
          if(temp.gt.test)test=temp
14      continue
        if(test.lt.TOLX) goto 1111
        dg(1:n)=g(1:n)
        !...................
        call dfunc(n, p, g, tmp)
        test=0.d0
        den=dmax1(fret,1.d0)
        do 16 i=1,n
          temp=dabs(g(i))*dmax1(dabs(p(i)),1.d0)/den
          if(temp.gt.test)test=temp
16      continue
        if(test.lt.gtol) goto 1111
        testg=test
        if (iprint>0.and.mod(its,iprint)==0)write(*,*)'iter=',iter, fp

        dg(1:n) = g(1:n) - dg(1:n)
        do i=1,n
          hdg(i)=0.d0
          do  j=1,n
            hdg(i)=hdg(i)+hessin(i,j)*dg(j)
          enddo
        enddo
        fac = sum(dg(1:n)*xi(1:n))
        fae = sum(dg(1:n)*hdg(1:n))
        sumdg=sum(dg(1:n)**2)
        sumxi=sum(xi(1:n)**2)
        if(fac.gt.dsqrt(EPS*sumdg*sumxi))then
          fac=1.d0/fac
          fad=1.d0/fae
          do 22 i=1,n
            dg(i)=fac*xi(i)-fad*hdg(i)
22        continue
          do 24 i=1,n
            do 23 j=i,n
              hessin(i,j)=hessin(i,j)+fac*xi(i)*xi(j)-fad*hdg(i)*hdg(j)+  &
                                              fae*dg(i)*dg(j)
              hessin(j,i)=hessin(i,j)
23          continue
24        continue
        endif
        do 26 i=1,n
          xi(i)=0.d0
          do 25 j=1,n
            xi(i)=xi(i)-hessin(i,j)*g(j)
25        continue
26      continue
27    continue
      stop 'too many iterations in dfpmin'
1111  continue   ! return

      fret = fp

      deallocate(xi)
      deallocate(hessin)
      deallocate(g)
      deallocate(dg)
      deallocate(hdg)
      deallocate(pnew)
      END SUBROUTINE dfpmin
!.......................................................................
      SUBROUTINE lnsrch(n,xold,fold,g,p,x,f,stpmax,tolx, check, dfunc)
!.......................................................................
      implicit none
      LOGICAL check
      integer :: n
      double precision ::  f,fold,stpmax,g(n),p(n), x(n),xold(n), g0(n)
      double precision, parameter :: ALF=1.d-4
      EXTERNAL dfunc
      INTEGER i
      double precision :: a,alam,alam2,alamin,b,disc,f2,rhs1,rhs2,slope,sum, &
                          temp, test,tmplam, tolx

      check=.false.
      sum=0.d0
      do 11 i=1,n
        sum=sum+p(i)*p(i)
11    continue
      sum=dsqrt(sum)
      if(sum.gt.stpmax)then
        do 12 i=1,n
          p(i)=p(i)*stpmax/sum
12      continue
      endif
      slope=0.d0
      do 13 i=1,n
        slope=slope+g(i)*p(i)
13    continue
      if(slope.ge.0.d0) stop 'roundoff problem in lnsrch'
      test=0.d0
      do 14 i=1,n
        temp=dabs(p(i))/dmax1(dabs(xold(i)),1.d0)
        if(temp.gt.test)test=temp
14    continue
      alamin=TOLX/test
      alam=1.d0
1     continue
        do 15 i=1,n
          x(i)=xold(i)+alam*p(i)
15      continue
        call dfunc(n, x, g0, f)
        if(alam.lt.alamin)then
          do 16 i=1,n
            x(i)=xold(i)
16        continue
          check=.true.
          goto 1111
        else if(f.le.fold+ALF*alam*slope)then
          goto 1111
        else
          if(alam.eq.1.d0)then
            tmplam=-slope/(2.d0*(f-fold-slope))
          else
            rhs1=f-fold-alam*slope
            rhs2=f2-fold-alam2*slope
            a=(rhs1/alam**2-rhs2/alam2**2)/(alam-alam2)
            b=(-alam2*rhs1/alam**2+alam*rhs2/alam2**2)/(alam-alam2)
            if(a.eq.0.d0)then
              tmplam=-slope/(2.d0*b)
            else
              disc=b*b-3.d0*a*slope
              if(disc.lt.0.d0)then
                tmplam=.5d0*alam
              else if(b.le.0.d0)then
                tmplam=(-b+dsqrt(disc))/(3.d0*a)
              else
                tmplam=-slope/(b+dsqrt(disc))
              endif
            endif
            if(tmplam.gt.0.5d0*alam)tmplam=0.5d0*alam
          endif
        endif
        alam2=alam
        f2=f
        alam=dmax1(tmplam,0.1d0*alam)
      goto 1
1111  return
      END SUBROUTINE lnsrch
end module dfpmin_mod


subroutine orthogonal(Ov,HOv,EEOv)
 USE variables
 implicit none

 integer i,j,k,l,m,n,o
 integer INFO, LWORK
 real*8  Ov(n_bas,n_bas),HOv(n_bas,n_bas),EEOv(n_bas,n_bas,n_bas,n_bas)
 real*8  X1(n_bas,n_bas),W(n_bas),WORK(3*n_bas-1),S1(n_bas,n_bas)
 integer a,b,c,d

 allocate ( S(n_bas,n_bas),H(n_bas,n_bas),EE(n_bas,n_bas,n_bas,n_bas), &
          STAT = AllocateStatus)

!-------------------------------------------------------------
! Working in orthogonal basis

 S1=Ov

 LWORK=3*n_bas-1
 call DSYEV( 'V', 'U', n_bas, Ov, n_bas, W, WORK, LWORK, INFO )

 do i=1,n_bas
    do  j=1,n_bas
      X1(i,j)=Ov(i,j)/sqrt(W(j))
    end do
 end do

! Symmetric Orthogonalization
! do i=1,3
!    do  j=1,3
!      X1(i,j)=Ov(i,j)/sqrt(W(j))
!    end do
! end do
!Xsymm=matmul(X1,transpose(Ov))
!
!X1=Xsymm
!X1=0.d0

!do i=1,3
!X1(i,i)=1.d0
!enddo

S=matmul(transpose(X1),matmul(S1,X1))
H=matmul(transpose(X1),matmul(HOv,X1))

!do i =1,n_bas
!  print*,S(i,:)
!end do

do i=1,n_bas
  do j=1,n_bas
    do k=1,n_bas
      do l=1,n_bas

          EE(i,j,k,l)=0.d0

         do a=1,n_bas
          do b=1,n_bas
           do c=1,n_bas
            do d=1,n_bas
              EE(i,j,k,l)=EE(i,j,k,l)+X1(a,i)*X1(b,j)*X1(c,k)*X1(d,l)*EEOv(a,b,c,d)
            end do
           end do
          end do
         end do

       end do
     end do
   end do
 end do
!write(6,*) "Pass Ortho"
end subroutine


       SUBROUTINE SHRSLV(A,B,C,M,N,NA,NB,NC)
C
C   PURPOSE:
C      Solve the real matrix equation AX + XB = C, where A is an m x m
C      matrix in lower real Schur form and B is an n x n matrix in
C      upper real Schur form.
C
C   REFERENCES:
C      Bartels, R.H.; and Stewart, G.W.: Algorithm 432 - Solution of
C        the Matrix Equation AX + XB = C. Commun. ACM, vol. 15, no. 9,
C        Sept. 1972, pp. 820-826.
C
C   Subroutines employed by SHRSLV: SYSSLV
C   Subroutines employing SHRSLV: AXPXB
C
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8
     1A(NA,1),B(NB,1),C(NC,1),T,P
      INTEGER
     1M,N,NA,NB,NC,K,KM1,DK,KK,L,LM1,DL,LL,I,IB,J,JA,NSYS
      COMMON/SLVBLK/T(5,5),P(5),NSYS
      L = 1
   10   LM1 = L-1
        DL = 1
        IF(L .EQ. N) GO TO 15
        IF(B(L+1,L) .NE. 0.) DL = 2
   15   LL = L+DL-1
        IF(L .EQ. 1) GO TO 30
        DO 20 J=L,LL
          DO 20 I=1,M
            DO 20 IB=1,LM1
              C(I,J) = C(I,J) - C(I,IB)*B(IB,J)
   20   CONTINUE
   30   K = 1
   40     KM1 = K-1
          DK = 1
          IF(K .EQ. M) GO TO 45
          IF(A(K,K+1) .NE. 0.) DK = 2
   45     KK = K+DK-1
          IF(K .EQ. 1) GO TO 60
          DO 50 I=K,KK
            DO 50 J=L,LL
              DO 50 JA=1,KM1
                C(I,J) = C(I,J) - A(I,JA)*C(JA,J)
  50      CONTINUE
  60      IF(DL .EQ. 2) GO TO 80
          IF(DK .EQ. 2) GO TO 70
          T(1,1) = A(K,K) + B(L,L)
          IF(T(1,1) .EQ. 0.) STOP
          C(K,L) = C(K,L)/T(1,1)
          GO TO 100
  70      T(1,1) = A(K,K) + B(L,L)
          T(1,2) = A(K,KK)
          T(2,1) = A(KK,K)
          T(2,2) = A(KK,KK) + B(L,L)
          P(1) = C(K,L)
          P(2) = C(KK,L)
          NSYS = 2
          CALL SYSSLV
          C(K,L) = P(1)
          C(KK,L) = P(2)
          GO TO 100
  80      IF(DK .EQ. 2) GO TO 90
          T(1,1) = A(K,K) + B(L,L)
          T(1,2) = B(LL,L)
          T(2,1) = B(L,LL)
          T(2,2) = A(K,K) + B(LL,LL)
          P(1) = C(K,L)
          P(2) = C(K,LL)
          NSYS = 2
          CALL SYSSLV
          C(K,L) = P(1)
          C(K,LL) = P(2)
          GO TO 100
  90      T(1,1) = A(K,K) + B(L,L)
          T(1,2) = A(K,KK)
          T(1,3) = B(LL,L)
          T(1,4) = 0.
          T(2,1) = A(KK,K)
          T(2,2) = A(KK,KK) + B(L,L)
          T(2,3) = 0.
          T(2,4) = T(1,3)
          T(3,1) = B(L,LL)
          T(3,2) = 0.
          T(3,3) = A(K,K) + B(LL,LL)
          T(3,4) = T(1,2)
          T(4,1) = 0.
          T(4,2) = T(3,1)
          T(4,3) = T(2,1)
          T(4,4) = A(KK,KK) + B(LL,LL)
          P(1) = C(K,L)
          P(2) = C(KK,L)
          P(3) = C(K,LL)
          P(4) = C(KK,LL)
          NSYS = 4
          CALL SYSSLV
          C(K,L) = P(1)
          C(KK,L) = P(2)
          C(K,LL) = P(3)
          C(KK,LL) = P(4)
  100   K = K + DK
        IF(K .LE. M) GO TO 40
      L = L + DL
      IF(L .LE. N) GO TO 10
      RETURN
      END


*> \brief  SSPSVX computes the solution to system of linear equations A * X = B for OTHER matrices
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SSPSVX + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE SSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X,
*                          LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          FACT, UPLO
*       INTEGER            INFO, LDB, LDX, N, NRHS
*       REAL               RCOND
*       ..
*       .. Array Arguments ..
*       INTEGER            IPIV( * ), IWORK( * )
*       REAL               AFP( * ), AP( * ), B( LDB, * ), BERR( * ),
*      $                   FERR( * ), WORK( * ), X( LDX, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SSPSVX uses the diagonal pivoting factorization A = U*D*U**T or
*> A = L*D*L**T to compute the solution to a real system of linear
*> equations A * X = B, where A is an N-by-N symmetric matrix stored
*> in packed format and X and B are N-by-NRHS matrices.
*>
*> Error bounds on the solution and a condition estimate are also
*> provided.
*> \endverbatim
*
*> \par Description:
*  =================
*>
*> \verbatim
*>
*> The following steps are performed:
*>
*> 1. If FACT = 'N', the diagonal pivoting method is used to factor A as
*>       A = U * D * U**T,  if UPLO = 'U', or
*>       A = L * D * L**T,  if UPLO = 'L',
*>    where U (or L) is a product of permutation and unit upper (lower)
*>    triangular matrices and D is symmetric and block diagonal with
*>    1-by-1 and 2-by-2 diagonal blocks.
*>
*> 2. If some D(i,i)=0, so that D is exactly singular, then the routine
*>    returns with INFO = i. Otherwise, the factored form of A is used
*>    to estimate the condition number of the matrix A.  If the
*>    reciprocal of the condition number is less than machine precision,
*>    INFO = N+1 is returned as a warning, but the routine still goes on
*>    to solve for X and compute error bounds as described below.
*>
*> 3. The system of equations is solved for X using the factored form
*>    of A.
*>
*> 4. Iterative refinement is applied to improve the computed solution
*>    matrix and calculate error bounds and backward error estimates
*>    for it.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] FACT
*> \verbatim
*>          FACT is CHARACTER*1
*>          Specifies whether or not the factored form of A has been
*>          supplied on entry.
*>          = 'F':  On entry, AFP and IPIV contain the factored form of
*>                  A.  AP, AFP and IPIV will not be modified.
*>          = 'N':  The matrix A will be copied to AFP and factored.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*>          UPLO is CHARACTER*1
*>          = 'U':  Upper triangle of A is stored;
*>          = 'L':  Lower triangle of A is stored.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of linear equations, i.e., the order of the
*>          matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*>          NRHS is INTEGER
*>          The number of right hand sides, i.e., the number of columns
*>          of the matrices B and X.  NRHS >= 0.
*> \endverbatim
*>
*> \param[in] AP
*> \verbatim
*>          AP is REAL array, dimension (N*(N+1)/2)
*>          The upper or lower triangle of the symmetric matrix A, packed
*>          columnwise in a linear array.  The j-th column of A is stored
*>          in the array AP as follows:
*>          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
*>          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
*>          See below for further details.
*> \endverbatim
*>
*> \param[in,out] AFP
*> \verbatim
*>          AFP is REAL array, dimension
*>                            (N*(N+1)/2)
*>          If FACT = 'F', then AFP is an input argument and on entry
*>          contains the block diagonal matrix D and the multipliers used
*>          to obtain the factor U or L from the factorization
*>          A = U*D*U**T or A = L*D*L**T as computed by SSPTRF, stored as
*>          a packed triangular matrix in the same storage format as A.
*>
*>          If FACT = 'N', then AFP is an output argument and on exit
*>          contains the block diagonal matrix D and the multipliers used
*>          to obtain the factor U or L from the factorization
*>          A = U*D*U**T or A = L*D*L**T as computed by SSPTRF, stored as
*>          a packed triangular matrix in the same storage format as A.
*> \endverbatim
*>
*> \param[in,out] IPIV
*> \verbatim
*>          IPIV is INTEGER array, dimension (N)
*>          If FACT = 'F', then IPIV is an input argument and on entry
*>          contains details of the interchanges and the block structure
*>          of D, as determined by SSPTRF.
*>          If IPIV(k) > 0, then rows and columns k and IPIV(k) were
*>          interchanged and D(k,k) is a 1-by-1 diagonal block.
*>          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
*>          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
*>          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =
*>          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
*>          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
*>
*>          If FACT = 'N', then IPIV is an output argument and on exit
*>          contains details of the interchanges and the block structure
*>          of D, as determined by SSPTRF.
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*>          B is REAL array, dimension (LDB,NRHS)
*>          The N-by-NRHS right hand side matrix B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of the array B.  LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] X
*> \verbatim
*>          X is REAL array, dimension (LDX,NRHS)
*>          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
*> \endverbatim
*>
*> \param[in] LDX
*> \verbatim
*>          LDX is INTEGER
*>          The leading dimension of the array X.  LDX >= max(1,N).
*> \endverbatim
*>
*> \param[out] RCOND
*> \verbatim
*>          RCOND is REAL
*>          The estimate of the reciprocal condition number of the matrix
*>          A.  If RCOND is less than the machine precision (in
*>          particular, if RCOND = 0), the matrix is singular to working
*>          precision.  This condition is indicated by a return code of
*>          INFO > 0.
*> \endverbatim
*>
*> \param[out] FERR
*> \verbatim
*>          FERR is REAL array, dimension (NRHS)
*>          The estimated forward error bound for each solution vector
*>          X(j) (the j-th column of the solution matrix X).
*>          If XTRUE is the true solution corresponding to X(j), FERR(j)
*>          is an estimated upper bound for the magnitude of the largest
*>          element in (X(j) - XTRUE) divided by the magnitude of the
*>          largest element in X(j).  The estimate is as reliable as
*>          the estimate for RCOND, and is almost always a slight
*>          overestimate of the true error.
*> \endverbatim
*>
*> \param[out] BERR
*> \verbatim
*>          BERR is REAL array, dimension (NRHS)
*>          The componentwise relative backward error of each solution
*>          vector X(j) (i.e., the smallest relative change in
*>          any element of A or B that makes X(j) an exact solution).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is REAL array, dimension (3*N)
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*>          IWORK is INTEGER array, dimension (N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0: successful exit
*>          < 0: if INFO = -i, the i-th argument had an illegal value
*>          > 0:  if INFO = i, and i is
*>                <= N:  D(i,i) is exactly zero.  The factorization
*>                       has been completed but the factor D is exactly
*>                       singular, so the solution and error bounds could
*>                       not be computed. RCOND = 0 is returned.
*>                = N+1: D is nonsingular, but RCOND is less than machine
*>                       precision, meaning that the matrix is singular
*>                       to working precision.  Nevertheless, the
*>                       solution and error bounds are computed because
*>                       there are a number of situations where the
*>                       computed solution can be more accurate than the
*>                       value of RCOND would suggest.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date April 2012
*
*> \ingroup realOTHERsolve
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  The packed storage scheme is illustrated by the following example
*>  when N = 4, UPLO = 'U':
*>
*>  Two-dimensional storage of the symmetric matrix A:
*>
*>     a11 a12 a13 a14
*>         a22 a23 a24
*>             a33 a34     (aij = aji)
*>                 a44
*>
*>  Packed storage of the upper triangle of A:
*>
*>  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
*> \endverbatim
*>
*  =====================================================================
      SUBROUTINE SSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X,
     $                   LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )
*
*  -- LAPACK driver routine (version 3.4.1) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     April 2012
*
*     .. Scalar Arguments ..
      CHARACTER          FACT, UPLO
      INTEGER            INFO, LDB, LDX, N, NRHS
      REAL               RCOND
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * ), IWORK( * )
      REAL               AFP( * ), AP( * ), B( LDB, * ), BERR( * ),
     $                   FERR( * ), WORK( * ), X( LDX, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO
      PARAMETER          ( ZERO = 0.0E+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            NOFACT
      REAL               ANORM
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      REAL               SLAMCH, SLANSP
      EXTERNAL           LSAME, SLAMCH, SLANSP
*     ..
*     .. External Subroutines ..
      EXTERNAL           SCOPY, SLACPY, SSPCON, SSPRFS, SSPTRF, SSPTRS,
     $                   XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      NOFACT = LSAME( FACT, 'N' )
      IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) )
     $          THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -11
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SSPSVX', -INFO )
         RETURN
      END IF
*
      IF( NOFACT ) THEN
*
*        Compute the factorization A = U*D*U**T or A = L*D*L**T.
*
         CALL SCOPY( N*( N+1 ) / 2, AP, 1, AFP, 1 )
         CALL SSPTRF( UPLO, N, AFP, IPIV, INFO )
*
*        Return if INFO is non-zero.
*
         IF( INFO.GT.0 )THEN
            RCOND = ZERO
            RETURN
         END IF
      END IF
*
*     Compute the norm of the matrix A.
*
      ANORM = SLANSP( 'I', UPLO, N, AP, WORK )
*
*     Compute the reciprocal of the condition number of A.
*
      CALL SSPCON( UPLO, N, AFP, IPIV, ANORM, RCOND, WORK, IWORK, INFO )
*
*     Compute the solution vectors X.
*
      CALL SLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
      CALL SSPTRS( UPLO, N, NRHS, AFP, IPIV, X, LDX, INFO )
*
*     Use iterative refinement to improve the computed solutions and
*     compute error bounds and backward error estimates for them.
*
      CALL SSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR,
     $             BERR, WORK, IWORK, INFO )
*
*     Set INFO = N+1 if the matrix is singular to working precision.
*
      IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
     $   INFO = N + 1
*
      RETURN
*
*     End of SSPSVX
*
      END


      subroutine res_nutrient (jres, inut, iob)

      use reservoir_data_module
      use time_module
      use reservoir_module
      use hydrograph_module, only : res, resz, ob, ht2, wbody
      use climate_module

      implicit none

      integer, intent (in) :: iob
      real :: nitrok             !              |
      real :: phosk              !              |
      real :: tpco               !              |
      real :: chlaco             !              |
      integer :: jres            !none          |reservoir number
      integer :: inut            !none          |counter
      integer :: iwst            !none          |weather station number
      real :: nsetlr             !              |
      real :: psetlr             !              |
      real :: conc_n             !              |
      real :: conc_p             !              |
      real :: theta              !              |

      !! if reservoir volume less than 1 m^3, set all nutrient levels to
      !! zero and perform no nutrient calculations
      if (wbody%flo < 1.e-6) then
        wbody = resz
        return
      end if

      !! if reservoir volume greater than 1 m^3, perform nutrient calculations
      if (time%mo >= res_nut(inut)%ires1 .and. time%mo <= res_nut(inut)%ires2) then
        nsetlr = res_nut(inut)%nsetlr1
        psetlr = res_nut(inut)%psetlr1
      else
        nsetlr = res_nut(inut)%nsetlr2
        psetlr = res_nut(inut)%psetlr2
      endif

      !! n and p concentrations kg/m3 * kg/1000 t * 1000000 ppp = 1000
      conc_n = 1000. * (wbody%orgn + wbody%no3 + wbody%nh3 + wbody%no2) / wbody%flo
      conc_p = 1000. * (wbody%sedp + wbody%solp) / wbody%flo

      !! new inputs thetn, thetap, conc_pmin, conc_nmin
      !! Ikenberry wetland eqs modified - not function of area - fraction of difference in concentrations
      iwst = ob(iob)%wst
      nitrok = (conc_n - res_nut(inut)%conc_nmin) * Theta(nsetlr, res_nut(inut)%theta_n, wst(iwst)%weat%tave)
      nitrok = amin1 (nitrok, 1.)
      nitrok = amax1 (nitrok, 0.)
      phosk = (conc_p - res_nut(inut)%conc_pmin) * Theta(psetlr, res_nut(inut)%theta_p, wst(iwst)%weat%tave)
      phosk = amin1 (phosk, 1.)
      phosk = amax1 (phosk, 0.)

      !! remove nutrients from reservoir by settling
      !! other part of equation 29.1.3 in SWAT manual
      wbody%solp = wbody%solp * (1. - phosk)
      wbody%sedp = wbody%sedp * (1. - phosk)
      wbody%orgn = wbody%orgn * (1. - nitrok)
      wbody%no3 = wbody%no3 * (1. - nitrok)
      wbody%nh3 = wbody%nh3 * (1. - nitrok)
      wbody%no2 = wbody%no2 * (1. - nitrok)

      !! calculate chlorophyll-a and water clarity
      chlaco = 0.
      wbody%chla = 0.
      tpco = 1.e+6 * (wbody%solp + wbody%sedp) / (wbody%flo + ht2%flo)
      if (tpco > 1.e-4) then
        !! equation 29.1.6 in SWAT manual
        chlaco = res_nut(inut)%chlar * 0.551 * (tpco**0.76)
        wbody%chla = chlaco * (wbody%flo + ht2%flo) * 1.e-6
      endif
      !res_ob(jres)%seci = 0.
      !if (chlaco > 1.e-4) then
      !  !! equation 29.1.8 in SWAT manual
      !  res_ob(jres)%seci = res_nut(inut)%seccir * 6.35 * (chlaco ** (-0.473))
      !endif

      !! check nutrient masses greater than zero
      wbody%no3 = amax1 (wbody%no3, 0.0)
      wbody%orgn = amax1 (wbody%orgn, 0.0)
      wbody%sedp = amax1 (wbody%sedp, 0.0)
      wbody%solp = amax1 (wbody%solp, 0.0)
      wbody%chla = amax1 (wbody%chla, 0.0)
      wbody%nh3 = amax1 (wbody%nh3, 0.0)
      wbody%no2 = amax1 (wbody%no2, 0.0)

      !! calculate amount of nutrients leaving reservoir
      ht2%no3 = wbody%no3 * ht2%flo / (wbody%flo + ht2%flo)
      ht2%orgn = wbody%orgn * ht2%flo / (wbody%flo + ht2%flo)
      ht2%sedp = wbody%sedp * ht2%flo / (wbody%flo + ht2%flo)
      ht2%solp = wbody%solp * ht2%flo / (wbody%flo + ht2%flo)
      ht2%chla = wbody%chla * ht2%flo / (wbody%flo + ht2%flo)
      ht2%nh3 = wbody%nh3 * ht2%flo / (wbody%flo + ht2%flo)
      ht2%no2 = wbody%no2 * ht2%flo / (wbody%flo + ht2%flo)

      return
      end subroutine res_nutrient


SUBROUTINE sdst(x,dg,dg1,i)
!
IMPLICIT NONE
!
! Subroutine arguments
!
REAL :: dg,dg1
INTEGER :: i
REAL,DIMENSION(*) :: x
!
!     + + + purpose + + +
!     this subroutine initializes residue, nitorgen, and phosphorous amounts in
!     layers

!     + + + keywords + + +
!     initialization

!     + + + local variables + + +

!     + + + local definitions + + +
!     dg    -
!     dg1   -
!     i     -
!     x     -

!      dimension x(10)

!     + + + end specifications + + +

!     data e/'e'/
IF (x(i).LE.0.) THEN
  IF (i.GT.1) THEN
     x(i) = x(i-1)*dg*exp(-.01*dg)/dg1
  ELSE
     x(1) = 1.
  END IF
END IF
!   3 est(j,i)=e
!
END SUBROUTINE sdst

Project Documents/Source Code Original/Sdst.f90


C
      SUBROUTINE ACRE(X,Y,Z,V)
C$$$  SUBPROGRAM DOCUMENTATION  BLOCK
C SUBPROGRAM:    ACRE         COMPUTES RATE OF ICE ACCRETION
C   PRGMMR: D. M. FEIT       ORG: W/NMC21    DATE: 87-06-26
C
C ABSTRACT: COMPUTES RATE OF ICE ACCRETION WITH PMEL ALGORITHM.
C
C PROGRAM HISTORY LOG:
C   87-06-26  D. M. FEIT
C   96-07-23  L. D. BURROUGHS - CONVERTED FOR USE ON CRAY
C
C USAGE:    CALL ACRE(X,Y,Z,V)
C
C   INPUT ARGUMENT LIST:
C     X        - AIR TEMPERATURE IN DEG CELCIUS
C     Y        - SEA SURFACE TEMPERATURE IN DEG CELCIUS
C     Z        - WIND SPEED IN METERS/SEC
C
C   OUTPUT ARGUMENT LIST:
C     V        - RATE OF ICE ACCRETION IN CM/HR
C
C   INPUT FILES: NONE
C
C   OUTPUT FILES: NONE
C
C   SUBPROGRAMS CALLED:
C     UNIQUE     - NONE
C
C     LIBRARY:
C       W3LIB    - NONE
C
C       IMSL     - NONE
C
C       SPECIAL  - NONE
C
C REMARKS: NONE
C
C     VARIABLES:
C       INPUT    - X          = AIR TEMPERATURE IN DEG CELCIUS
C                  Y          = SEA SURFACE TEMPERATURE IN DEG CELCIUS
C                  Z          = WIND SPEED IN METERS/SEC
C
C       INTERNAL - A          = 1ST OF THREE CONSTANTS FOR CUBIC FIT
C                  B          = 2ND OF THREE CONSTANTS FOR CUBIC FIT
C                  C          = 3RD OF THREE CONSTANTS FOR CUBIC FIT
C                  PR         = FUNCTIONAL RELATION OF INPUTS X, Y,
C                               AND Z
C
C       OUTPUT   - V          = RATE OF ICE ACCRETION IN CM/HR
C
C ATTRIBUTES:
C   LANGUAGE: CF77
C   MACHINE:  CRAY3
C
C$$$
      SAVE
      A=2.73E-02
      B=2.91E-04
      C=1.84E-06
      PR=Z*(-1.7-X)/(1.+.4*(Y+1.7))
      V=A*PR+B*PR*PR+C*PR**3
      RETURN
      END


*     FB01SD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDAINV, LDB, LDC, LDQINV, LDRINV, LDSINV
      PARAMETER        ( LDAINV = NMAX, LDB = NMAX, LDC = PMAX,
     $                   LDQINV = MMAX, LDRINV = PMAX, LDSINV = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( NMAX*(NMAX + 2*MMAX) + 3*MMAX,
     $                                (NMAX + PMAX)*(NMAX + 1) + 2*NMAX,
     $                                 3*NMAX ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INFO, ISTEP, J, M, N, P
      CHARACTER*1      JOBX, MULTAB, MULTRC
*     .. Local Arrays ..
      DOUBLE PRECISION AINV(LDAINV,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 DIAG(MMAX), DWORK(LDWORK), E(PMAX),
     $                 QINV(LDQINV,MMAX), RINV(LDRINV,PMAX),
     $                 RINVY(PMAX), SINV(LDSINV,NMAX), X(NMAX), Z(MMAX)
      INTEGER          IWORK(NMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         DCOPY, FB01SD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, JOBX, TOL, MULTAB, MULTRC
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( AINV(I,J), J = 1,N ), I = 1,N )
         IF ( P.LE.0 .OR. P.GT.PMAX ) THEN
            WRITE ( NOUT, FMT = 99991 ) P
         ELSE
            READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
            IF ( LSAME( MULTRC, 'N' ) ) READ ( NIN, FMT = * )
     $                               ( ( RINV(I,J), J = 1,P ), I = 1,P )
            IF ( M.LE.0 .OR. M.GT.MMAX ) THEN
               WRITE ( NOUT, FMT = 99992 ) M
            ELSE
               READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
               READ ( NIN, FMT = * ) ( ( QINV(I,J), J = 1,M ), I = 1,M )
               READ ( NIN, FMT = * ) ( ( SINV(I,J), J = 1,N ), I = 1,N )
               READ ( NIN, FMT = * ) ( Z(J), J = 1,M )
               READ ( NIN, FMT = * ) ( X(J), J = 1,N )
               READ ( NIN, FMT = * ) ( RINVY(J), J = 1,P )
*              Save the strict upper triangle of QINV in its strict
*              lower triangle and the diagonal in the array DIAG.
               DO 10 I = 2, M
                  CALL DCOPY( I, QINV(1,I), 1, QINV(I,1), LDQINV )
   10          CONTINUE
               CALL DCOPY( M, QINV, LDQINV+1, DIAG, 1 )
*              Perform three iterations of the (Kalman) filter recursion
*              (in square root information form).
               ISTEP = 1
   20          CONTINUE
                  CALL FB01SD( JOBX, MULTAB, MULTRC, N, M, P, SINV,
     $                         LDSINV, AINV, LDAINV, B, LDB, RINV,
     $                         LDRINV, C, LDC, QINV, LDQINV, X, RINVY,
     $                         Z, E, TOL, IWORK, DWORK, LDWORK, INFO )
                  ISTEP = ISTEP + 1
                  IF ( INFO.EQ.0 .AND. ISTEP.LE.3 ) THEN
*                    Restore the upper triangle of QINV.
                     DO 30 I = 2, M
                        CALL DCOPY( I, QINV(I,1), LDQINV, QINV(1,I), 1 )
   30                CONTINUE
                     CALL DCOPY( M, DIAG, 1, QINV, LDQINV+1 )
                     GO TO 20
                  END IF
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 )
                  DO 40 I = 1, N
                     WRITE ( NOUT, FMT = 99996 ) ( SINV(I,J), J = 1,N )
   40             CONTINUE
                  IF ( LSAME( JOBX, 'X' ) ) THEN
                     WRITE ( NOUT, FMT = 99995 )
                     DO 50 I = 1, N
                        WRITE ( NOUT, FMT = 99994 ) I, X(I)
   50                CONTINUE
                  END IF
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' FB01SD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from FB01SD = ',I2)
99997 FORMAT (' The inverse of the square root of the state covariance',
     $       ' matrix is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' The components of the estimated filtered state are ',
     $       //'   k       X(k)',/)
99994 FORMAT (I4,3X,F8.4)
99993 FORMAT (/' N is out of range.',/' N = ',I5)
99992 FORMAT (/' M is out of range.',/' M = ',I5)
99991 FORMAT (/' P is out of range.',/' P = ',I5)
      END


program fullcovtest
  use flips

  implicit none

  type(flips_s) :: fs
  integer :: n,i
  real(sp), dimension(:), allocatable :: amat,mvec,emat

  real(dp) :: ts,te

  write(*,*) 'Anna koko:'
  read(*,*) n

  allocate(amat(n**2),mvec(n),emat(n*(n+1)/2))

  call random_number(amat)
  call random_number(mvec)
  call random_number(emat)

  do i = 1,n
     emat(rind(i,i,n)) = n
  end do

  call cpu_time(ts)
  call flips_init(fs,n,1,buffersize=100)
write(*,*) 'Adding data...'
  call flips_add_fc(fs,n,amat,mvec,emat)
write(*,*) 'Done!'
  call flips_solve(fs)
  call cpu_time(te)

  write(*,*) 'Size:',n,'CPU time:',te-ts
  write(*,*) fs%solmat(1:5)

  deallocate(amat,emat,mvec)

  call flips_kill(fs)

end program fullcovtest


!*==dlasq1.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b DLASQ1 computes the singular values of a real square bidiagonal matrix. Used by sbdsqr.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download DLASQ1 + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE DLASQ1( N, D, E, WORK, INFO )
!
!       .. Scalar Arguments ..
!       INTEGER            INFO, N
!       ..
!       .. Array Arguments ..
!       DOUBLE PRECISION   D( * ), E( * ), WORK( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> DLASQ1 computes the singular values of a real N-by-N bidiagonal
!> matrix with diagonal D and off-diagonal E. The singular values
!> are computed to high relative accuracy, in the absence of
!> denormalization, underflow and overflow. The algorithm was first
!> presented in
!>
!> "Accurate singular values and differential qd algorithms" by K. V.
!> Fernando and B. N. Parlett, Numer. Math., Vol-67, No. 2, pp. 191-230,
!> 1994,
!>
!> and the present implementation is described in "An implementation of
!> the dqds Algorithm (Positive Case)", LAPACK Working Note.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>        The number of rows and columns in the matrix. N >= 0.
!> \endverbatim
!>
!> \param[in,out] D
!> \verbatim
!>          D is DOUBLE PRECISION array, dimension (N)
!>        On entry, D contains the diagonal elements of the
!>        bidiagonal matrix whose SVD is desired. On normal exit,
!>        D contains the singular values in decreasing order.
!> \endverbatim
!>
!> \param[in,out] E
!> \verbatim
!>          E is DOUBLE PRECISION array, dimension (N)
!>        On entry, elements E(1:N-1) contain the off-diagonal elements
!>        of the bidiagonal matrix whose SVD is desired.
!>        On exit, E is overwritten.
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is DOUBLE PRECISION array, dimension (4*N)
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>        = 0: successful exit
!>        < 0: if INFO = -i, the i-th argument had an illegal value
!>        > 0: the algorithm failed
!>             = 1, a split was marked by a positive value in E
!>             = 2, current block of Z not diagonalized after 100*N
!>                  iterations (in inner while loop)  On exit D and E
!>                  represent a matrix with the same singular values
!>                  which the calling subroutine could use to finish the
!>                  computation, or even feed back into DLASQ1
!>             = 3, termination criterion of outer while loop not met
!>                  (program created more than N unreduced blocks)
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup auxOTHERcomputational
!
!  =====================================================================
      SUBROUTINE DLASQ1(N,D,E,Work,Info)
      IMPLICIT NONE
!*--DLASQ1112
!
!  -- LAPACK computational routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      INTEGER Info , N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION D(*) , E(*) , Work(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.0D0)
!     ..
!     .. Local Scalars ..
      INTEGER i , iinfo
      DOUBLE PRECISION eps , scale , safmin , sigmn , sigmx
!     ..
!     .. External Subroutines ..
      EXTERNAL DCOPY , DLAS2 , DLASCL , DLASQ2 , DLASRT , XERBLA
!     ..
!     .. External Functions ..
      DOUBLE PRECISION DLAMCH
      EXTERNAL DLAMCH
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , MAX , SQRT
!     ..
!     .. Executable Statements ..
!
      Info = 0
      IF ( N<0 ) THEN
         Info = -1
         CALL XERBLA('DLASQ1',-Info)
         RETURN
      ELSEIF ( N==0 ) THEN
         RETURN
      ELSEIF ( N==1 ) THEN
         D(1) = ABS(D(1))
         RETURN
      ELSEIF ( N==2 ) THEN
         CALL DLAS2(D(1),E(1),D(2),sigmn,sigmx)
         D(1) = sigmx
         D(2) = sigmn
         RETURN
      ENDIF
!
!     Estimate the largest singular value.
!
      sigmx = ZERO
      DO i = 1 , N - 1
         D(i) = ABS(D(i))
         sigmx = MAX(sigmx,ABS(E(i)))
      ENDDO
      D(N) = ABS(D(N))
!
!     Early return if SIGMX is zero (matrix is already diagonal).
!
      IF ( sigmx==ZERO ) THEN
         CALL DLASRT('D',N,D,iinfo)
         RETURN
      ENDIF
!
      DO i = 1 , N
         sigmx = MAX(sigmx,D(i))
      ENDDO
!
!     Copy D and E into WORK (in the Z format) and scale (squaring the
!     input data makes scaling by a power of the radix pointless).
!
      eps = DLAMCH('Precision')
      safmin = DLAMCH('Safe minimum')
      scale = SQRT(eps/safmin)
      CALL DCOPY(N,D,1,Work(1),2)
      CALL DCOPY(N-1,E,1,Work(2),2)
      CALL DLASCL('G',0,0,sigmx,scale,2*N-1,1,Work,2*N-1,iinfo)
!
!     Compute the q's and e's.
!
      DO i = 1 , 2*N - 1
         Work(i) = Work(i)**2
      ENDDO
      Work(2*N) = ZERO
!
      CALL DLASQ2(N,Work,Info)
!
      IF ( Info==0 ) THEN
         DO i = 1 , N
            D(i) = SQRT(Work(i))
         ENDDO
         CALL DLASCL('G',0,0,scale,sigmx,N,1,D,N,iinfo)
      ELSEIF ( Info==2 ) THEN
!
!     Maximum number of iterations exceeded.  Move data from WORK
!     into D and E so the calling subroutine can try to finish
!
         DO i = 1 , N
            D(i) = SQRT(Work(2*i-1))
            E(i) = SQRT(Work(2*i))
         ENDDO
         CALL DLASCL('G',0,0,scale,sigmx,N,1,D,N,iinfo)
         CALL DLASCL('G',0,0,scale,sigmx,N,1,E,N,iinfo)
      ENDIF
!
!
!     End of DLASQ1
!
      END SUBROUTINE DLASQ1


! THIS VERSION: GALAHAD 2.1 - 22/03/2007 AT 09:00 GMT.
   PROGRAM GALAHAD_WCP_example
   USE GALAHAD_WCP_double                    ! double precision version
   IMPLICIT NONE
   INTEGER, PARAMETER :: wp = KIND( 1.0D+0 ) ! set precision
   REAL ( KIND = wp ), PARAMETER :: infinity = 10.0_wp ** 20
   TYPE ( QPT_problem_type ) :: p
   TYPE ( WCP_data_type ) :: data
   TYPE ( WCP_control_type ) :: control
   TYPE ( WCP_inform_type ) :: info
   INTEGER, PARAMETER :: n = 3, m = 2, a_ne = 4
   INTEGER :: i, s
! start problem data
   ALLOCATE( p%X( n ), p%X_l( n ), p%X_u( n ), p%Z_l( n ), p%Z_u( n ) )
   ALLOCATE( p%C( m ), p%C_l( m ), p%C_u( m ), p%Y_l( m ), p%Y_u( m ) )
   p%new_problem_structure = .TRUE.           ! new structure
   p%n = n ; p%m = m ; p%f = 0.0_wp           ! dimensions & objective constant
   p%C_l = (/ 1.0_wp, 2.0_wp /)               ! constraint lower bound
   p%C_u = (/ 2.0_wp, 2.0_wp /)               ! constraint upper bound
   p%X_l = (/ - 1.0_wp, - infinity, - infinity /) ! variable lower bound
   p%X_u = (/ 1.0_wp, infinity, 2.0_wp /)     ! variable upper bound
   p%gradient_kind = 0
! sparse co-ordinate storage format: integer components
   CALL SMT_put( p%A%type, 'COORDINATE', s )     ! storage for A
   ALLOCATE( p%A%val( a_ne ), p%A%row( a_ne ), p%A%col( a_ne ) )
   p%A%row = (/ 1, 1, 2, 2 /)                 ! Jacobian A
   p%A%col = (/ 1, 2, 2, 3 /) ; p%A%ne = a_ne
! integer components complete
   CALL WCP_initialize( data, control )       ! Initialize control parameters
   control%infinity = infinity                ! Set infinity
   p%X = (/  -2.0_wp, 1.0_wp,  3.0_wp /)      ! set x0
   p%Y_l = 1.0_wp ;  p%Y_u = - 1.0_wp ; p%Z_l = 1.0_wp ;  p%Z_u = - 1.0_wp
! sparse co-ordinate storage format: real components
   p%A%val = (/ 2.0_wp, 1.0_wp, 1.0_wp, 1.0_wp /) ! Jacobian A
! real components complete
   CALL WCP_solve( p, data, control, info )   ! Solve problem
   IF ( info%status == 0 ) THEN               ! Successful return
     WRITE( 6, "( 1X, I0, ' iterations. objective value =', ES11.4, /,         &
    &  ' well-centered point:', /, ' i     X_l           X         X_u' )" )   &
       info%iter, info%obj
     DO i = 1, n
       WRITE( 6, "( I2, 3ES12.4 )" ) i, p%X_l( i ), p%X( i ), p%X_u( i )
     END DO
     WRITE( 6, "( ' constraints:', /, ' i     C_l       A * X         C_u' )" )
     DO i = 1, m
       WRITE( 6, "( I2, 3ES12.4 )" ) i, p%C_l( i ), p%C( i ), p%C_u( i )
     END DO
   ELSE                                       !  Error returns
     WRITE( 6, "( ' WCP_solve exit status = ', I6 ) " ) info%status
   END IF
   CALL WCP_terminate( data, control, info )  !  delete internal workspace
   END PROGRAM GALAHAD_WCP_example


! Copyright 2019-2020 Free Software Foundation, Inc.
!
! This program is free software; you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation; either version 3 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program.  If not, see <http://www.gnu.org/licenses/>.

subroutine show (message, array)
  character (len=*) :: message
  integer, dimension (:,:) :: array

  print *, message
  do i=LBOUND (array, 2), UBOUND (array, 2), 1
     do j=LBOUND (array, 1), UBOUND (array, 1), 1
        write(*, fmt="(i4)", advance="no") array (j, i)
     end do
     print *, ""
 end do
 print *, array
 print *, ""

end subroutine show

program test

  interface
     subroutine show (message, array)
       character (len=*) :: message
       integer, dimension(:,:) :: array
     end subroutine show
  end interface

  integer, dimension (1:10,1:10) :: array
  integer, allocatable :: other (:, :)

  allocate (other (-5:4, -2:7))

  do i=LBOUND (array, 2), UBOUND (array, 2), 1
     do j=LBOUND (array, 1), UBOUND (array, 1), 1
        array (j,i) = ((i - 1) * UBOUND (array, 2)) + j
     end do
  end do

  do i=LBOUND (other, 2), UBOUND (other, 2), 1
     do j=LBOUND (other, 1), UBOUND (other, 1), 1
        other (j,i) = ((i - 1) * UBOUND (other, 2)) + j
     end do
  end do

  call show ("array", array)
  call show ("array (1:5,1:5)", array (1:5,1:5))
  call show ("array (1:10:2,1:10:2)", array (1:10:2,1:10:2))
  call show ("array (1:10:3,1:10:2)", array (1:10:3,1:10:2))
  call show ("array (1:10:5,1:10:3)", array (1:10:4,1:10:3))

  call show ("other", other)
  call show ("other (-5:0, -2:0)", other (-5:0, -2:0))
  call show ("other (-5:4:2, -2:7:3)", other (-5:4:2, -2:7:3))

  deallocate (other)
  print *, "" ! Final Breakpoint.
end program test


program array01

  integer, parameter :: size = 100
  integer :: i, j, b (size, size)

  i = 0
  j = 0

  do i=1,size
     do j=1,size
        b(j,i) = i
     end do
  end do

end program array01


      SUBROUTINE DSPMV(UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
!...Translated by Pacific-Sierra Research 77to90  4.3E  21:52:17  11/14/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE lsame_I
      USE xerbla_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER , INTENT(IN) :: N
      INTEGER , INTENT(IN) :: INCX
      INTEGER , INTENT(IN) :: INCY
      REAL(DOUBLE) , INTENT(IN) :: ALPHA
      REAL(DOUBLE) , INTENT(IN) :: BETA
      CHARACTER  :: UPLO
      REAL(DOUBLE) , INTENT(IN) :: AP(*)
      REAL(DOUBLE) , INTENT(IN) :: X(*)
      REAL(DOUBLE) , INTENT(INOUT) :: Y(*)
!-----------------------------------------------
!   L o c a l   P a r a m e t e r s
!-----------------------------------------------
      REAL(DOUBLE), PARAMETER :: ONE = 1.0D+0
      REAL(DOUBLE), PARAMETER :: ZERO = 0.0D+0
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY
      REAL(DOUBLE) :: TEMP1, TEMP2
!-----------------------------------------------
!     .. Scalar Arguments ..
!     .. Array Arguments ..
!     ..
!
!  Purpose
!  =======
!
!  DSPMV  performs the matrix-vector operation
!
!     y := alpha*A*x + beta*y,
!
!  where alpha and beta are scalars, x and y are n element vectors and
!  A is an n by n symmetric matrix, supplied in packed form.
!
!  Parameters
!  ==========
!
!  UPLO   - CHARACTER*1.
!           On entry, UPLO specifies whether the upper or lower
!           triangular part of the matrix A is supplied in the packed
!           array AP as follows:
!
!              UPLO = 'U' or 'u'   The upper triangular part of A is
!                                  supplied in AP.
!
!              UPLO = 'L' or 'l'   The lower triangular part of A is
!                                  supplied in AP.
!
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry, N specifies the order of the matrix A.
!           N must be at least zero.
!           Unchanged on exit.
!
!  ALPHA  - DOUBLE PRECISION.
!           On entry, ALPHA specifies the scalar alpha.
!           Unchanged on exit.
!
!  AP     - DOUBLE PRECISION array of DIMENSION at least
!           ( ( n*( n + 1 ) )/2 ).
!           Before entry with UPLO = 'U' or 'u', the array AP must
!           contain the upper triangular part of the symmetric matrix
!           packed sequentially, column by column, so that AP( 1 )
!           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
!           and a( 2, 2 ) respectively, and so on.
!           Before entry with UPLO = 'L' or 'l', the array AP must
!           contain the lower triangular part of the symmetric matrix
!           packed sequentially, column by column, so that AP( 1 )
!           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
!           and a( 3, 1 ) respectively, and so on.
!           Unchanged on exit.
!
!  X      - DOUBLE PRECISION array of dimension at least
!           ( 1 + ( n - 1 )*abs( INCX ) ).
!           Before entry, the incremented array X must contain the n
!           element vector x.
!           Unchanged on exit.
!
!  INCX   - INTEGER.
!           On entry, INCX specifies the increment for the elements of
!           X. INCX must not be zero.
!           Unchanged on exit.
!
!  BETA   - DOUBLE PRECISION.
!           On entry, BETA specifies the scalar beta. When BETA is
!           supplied as zero then Y need not be set on input.
!           Unchanged on exit.
!
!  Y      - DOUBLE PRECISION array of dimension at least
!           ( 1 + ( n - 1 )*abs( INCY ) ).
!           Before entry, the incremented array Y must contain the n
!           element vector y. On exit, Y is overwritten by the updated
!           vector y.
!
!  INCY   - INTEGER.
!           On entry, INCY specifies the increment for the elements of
!           Y. INCY must not be zero.
!           Unchanged on exit.
!
!
!  Level 2 Blas routine.
!
!  -- Written on 22-October-1986.
!     Jack Dongarra, Argonne National Lab.
!     Jeremy Du Croz, Nag Central Office.
!     Sven Hammarling, Nag Central Office.
!     Richard Hanson, Sandia National Labs.
!
!
!     .. Parameters ..
!     .. Local Scalars ..
!     .. External Functions ..
!     .. External Subroutines ..
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
         INFO = 1
      ELSE IF (N < 0) THEN
         INFO = 2
      ELSE IF (INCX == 0) THEN
         INFO = 6
      ELSE IF (INCY == 0) THEN
         INFO = 9
      ENDIF
      IF (INFO /= 0) THEN
         CALL XERBLA ('DSPMV ', INFO)
         RETURN
      ENDIF
!
!     Quick return if possible.
!
      IF (N==0 .OR. ALPHA==ZERO .AND. BETA==ONE) RETURN
!
!     Set up the start points in  X  and  Y.
!
      IF (INCX > 0) THEN
         KX = 1
      ELSE
         KX = 1 - (N - 1)*INCX
      ENDIF
      IF (INCY > 0) THEN
         KY = 1
      ELSE
         KY = 1 - (N - 1)*INCY
      ENDIF
!
!     Start the operations. In this version the elements of the array AP
!     are accessed sequentially with one pass through AP.
!
!     First form  y := beta*y.
!
      IF (BETA /= ONE) THEN
         IF (INCY == 1) THEN
            IF (BETA == ZERO) THEN
               Y(:N) = ZERO
            ELSE
               Y(:N) = BETA*Y(:N)
            ENDIF
         ELSE
            IY = KY
            IF (BETA == ZERO) THEN
               Y(IY:(N-1)*INCY+IY:INCY) = ZERO
            ELSE
               Y(IY:(N-1)*INCY+IY:INCY) = BETA*Y(IY:(N-1)*INCY+IY:INCY)
            ENDIF
         ENDIF
      ENDIF
      IF (ALPHA == ZERO) RETURN
      KK = 1
      IF (LSAME(UPLO,'U')) THEN
!
!        Form  y  when AP contains the upper triangle.
!
         IF (INCX==1 .AND. INCY==1) THEN
            DO J = 1, N
               TEMP1 = ALPHA*X(J)
               TEMP2 = ZERO
               K = KK
               Y(:J-1) = Y(:J-1) + TEMP1*AP(K:J-2+K)
               TEMP2 = TEMP2 + SUM(AP(K:J-2+K)*X(:J-1))
               Y(J) = Y(J) + TEMP1*AP(KK+J-1) + ALPHA*TEMP2
               KK = KK + J
            END DO
         ELSE
            JX = KX
            JY = KY
            DO J = 1, N
               TEMP1 = ALPHA*X(JX)
               TEMP2 = ZERO
               IX = KX
               IY = KY
               Y(IY:(J-2)*INCY+IY:INCY) = Y(IY:(J-2)*INCY+IY:INCY) + TEMP1*AP(&
                  KK:J-2+KK)
               TEMP2 = TEMP2 + SUM(AP(KK:J-2+KK)*X(IX:(J-2)*INCX+IX:INCX))
               Y(JY) = Y(JY) + TEMP1*AP(KK+J-1) + ALPHA*TEMP2
               JX = JX + INCX
               JY = JY + INCY
               KK = KK + J
            END DO
         ENDIF
      ELSE
!
!        Form  y  when AP contains the lower triangle.
!
         IF (INCX==1 .AND. INCY==1) THEN
            DO J = 1, N
               TEMP1 = ALPHA*X(J)
               TEMP2 = ZERO
               Y(J) = Y(J) + TEMP1*AP(KK)
               K = KK + 1
               Y(J+1:N) = Y(J+1:N) + TEMP1*AP(K:N-J-1+K)
               TEMP2 = TEMP2 + SUM(AP(K:N-J-1+K)*X(J+1:N))
               Y(J) = Y(J) + ALPHA*TEMP2
               KK = KK + (N - J + 1)
            END DO
         ELSE
            JX = KX
            JY = KY
            DO J = 1, N
               TEMP1 = ALPHA*X(JX)
               TEMP2 = ZERO
               Y(JY) = Y(JY) + TEMP1*AP(KK)
               IX = JX
               IY = JY
               Y(IY+INCY:(N-J)*INCY+IY:INCY) = Y(IY+INCY:(N-J)*INCY+IY:INCY) + &
                  TEMP1*AP(KK+1:N-J+KK)
               TEMP2 = TEMP2 + SUM(AP(KK+1:N-J+KK)*X(IX+INCX:(N-J)*INCX+IX:INCX&
                  ))
               Y(JY) = Y(JY) + ALPHA*TEMP2
               JX = JX + INCX
               JY = JY + INCY
               KK = KK + (N - J + 1)
            END DO
         ENDIF
      ENDIF
!
      RETURN
!
!     End of DSPMV .
!
      END SUBROUTINE DSPMV


! Created by EverLookNeverSee@GitHub on 6/30/20
! This program applies quick sort algorithm on
! an arbitrary sized sequence of numbers.

program quick_sort
    interface
        ! declaring qs subroutine inside interface
        recursive subroutine qs(seq, first, last)
            integer, dimension(:), intent(inout) :: seq
            integer, intent(in) :: first, last
        end subroutine qs
    end interface
    ! declaring variables
    integer, allocatable, dimension(:) :: seq
    integer :: first, last, n, i
    ! getting length of sequence from user input
    do
        print *, "Enter length of sequence:"
        read *, n
        if (n > 0) then
            exit
        else
            print *, "Length should be positive integer!"
            cycle
        end if
    end do
    ! allocating memory space to array
    allocate(seq(n))
    ! getting elements of sequence from user
    print *, "Please enter the elements of sequence:"
    do i = 1, n
        print *, "Element number", i, ":"
        read *, seq(i)
    end do
    ! specifying first and last element
    first = 1
    last = n
    ! printing unsorted sequence
    print *, "a:",seq
    ! calling quick sort subroutine
    call qs(seq, first, last)
    ! printing sorted sequence
    print *, "a:", seq
end program quick_sort

! defining and implementing qs subroutine
recursive subroutine qs(seq, first, last)
    ! declaring dummy parameters and local variables
    integer, dimension(:), intent(inout) :: seq
    integer, intent(in) :: first, last
    integer :: mid, high, low, tmp
    ! initializing local variables
    mid = seq((first + last) / 2)
    high = last
    low = first
    ! quick sort algorithm
    do
        do while(seq(low) < mid)
            low = low + 1
        end do
        do while(seq(high) > mid)
            high = high - 1
        end do
        if (low <= high) then
            tmp = seq(low)
            seq(low) = seq(high)
            low = low + 1
            seq(high) = tmp
            high = high - 1
        end if
        if (low > high) then
            exit
        end if
    end do
    if (low < last) then
        call qs(seq, low, last)
    end if
    if (first < high) then
        call qs(seq, first, high)
    end if
end subroutine qs


! { dg-do compile }
! Tests the fix for PR27554, where the actual argument reference
! to abs would not be recognised as being to an intrinsic
! procedure and would produce junk in the assembler.
!
! Contributed by Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
!
      subroutine foo (proc, z)
        external proc
        real proc, z
        if ((proc(z) .ne. abs (z)) .and.
     &      (proc(z) .ne. alog10 (abs(z)))) call abort ()
        return
      end

        external cos
        interface
          function sin (a)
            real a, sin
          end function sin
        end interface

        intrinsic alog10
        real x
        x = 100.
! The reference here would prevent the actual arg from being seen
! as an intrinsic procedure in the call to foo.
        x = -abs(x)
        call foo(abs, x)
! The intrinsic function can be locally over-ridden by an interface
        call foo(sin, x)
! or an external declaration.
        call foo(cos, x)
! Just make sure with another intrinsic but this time not referenced.
        call foo(alog10, -x)
      end

      function sin (a)
        real a, sin
        sin = -a
        return
      end

      function cos (a)
        real a, cos
        cos = -a
        return
      end


          FUNCTION dFINT(NARG,ARG,NENT,ENT,TABLE)
C
C   INTERPOLATION ROUTINE. AUTHOR C. LETERTRE.
C   MODIFIED BY B. SCHORR, 1.07.1982.
C
          implicit real * 8 (a-h,o-z)
          INTEGER   NENT(*)
          REAL*8      ARG(*),   ENT(*),   TABLE(*)
          INTEGER   INDEX(32)
          REAL*8      WEIGHT(32)
          LOGICAL   MFLAG,    RFLAG
          DFINT  =  0.
          IF(NARG .LT. 1  .OR.  NARG .GT. 5)  GOTO 300
          LMAX      =  0
          ISTEP     =  1
          KNOTS     =  1
          INDEX(1)  =  1
          WEIGHT(1) =  1.
          DO 100    N  =  1, NARG
             X     =  ARG(N)
             NDIM  =  NENT(N)
             LOCA  =  LMAX
             LMIN  =  LMAX + 1
             LMAX  =  LMAX + NDIM
             IF(NDIM .GT. 2)  GOTO 10
             IF(NDIM .EQ. 1)  GOTO 100
             H  =  X - ENT(LMIN)
             IF(H .EQ. 0.)  GOTO 90
             ISHIFT  =  ISTEP
             IF(X-ENT(LMIN+1) .EQ. 0.)  GOTO 21
             ISHIFT  =  0
             ETA     =  H / (ENT(LMIN+1) - ENT(LMIN))
             GOTO 30
  10         LOCB  =  LMAX + 1
  11         LOCC  =  (LOCA+LOCB) / 2
             IF(X-ENT(LOCC))  12, 20, 13
  12         LOCB  =  LOCC
             GOTO 14
  13         LOCA  =  LOCC
  14         IF(LOCB-LOCA .GT. 1)  GOTO 11
             LOCA    =  MIN0( MAX0(LOCA,LMIN), LMAX-1 )
             ISHIFT  =  (LOCA - LMIN) * ISTEP
             ETA     =  (X - ENT(LOCA)) / (ENT(LOCA+1) - ENT(LOCA))
             GOTO 30
  20         ISHIFT  =  (LOCC - LMIN) * ISTEP
  21         DO 22  K  =  1, KNOTS
                INDEX(K)  =  INDEX(K) + ISHIFT
  22            CONTINUE
             GOTO 90
  30         DO 31  K  =  1, KNOTS
                INDEX(K)         =  INDEX(K) + ISHIFT
                INDEX(K+KNOTS)   =  INDEX(K) + ISTEP
                WEIGHT(K+KNOTS)  =  WEIGHT(K) * ETA
                WEIGHT(K)        =  WEIGHT(K) - WEIGHT(K+KNOTS)
  31            CONTINUE
             KNOTS  =  2*KNOTS
  90         ISTEP  =  ISTEP * NDIM
 100         CONTINUE
          DO 200    K  =  1, KNOTS
             I  =  INDEX(K)
             DFINT  =  DFINT + WEIGHT(K) * TABLE(I)
 200         CONTINUE
          RETURN
 300      CALL KERMTR('E104.1',LGFILE,MFLAG,RFLAG)
          IF(MFLAG) THEN
             IF(LGFILE .EQ. 0) THEN
                WRITE(*,1000) NARG
             ELSE
                WRITE(LGFILE,1000) NARG
             ENDIF
          ENDIF
          IF(.NOT. RFLAG) CALL ABEND
          RETURN
1000      FORMAT( 7X, 25HFUNCTION DFINT ... NARG =,I6,
     +              17H NOT WITHIN RANGE)
          END


!        Generated by TAPENADE     (INRIA, Ecuador team)
!  Tapenade 3.16 (master) -  9 Oct 2020 17:47
!
MODULE MOD_MEAN_B
  USE MOD_MATH_B, ONLY : divide_b, add_b
  IMPLICIT NONE
  PUBLIC :: mean_b
  PRIVATE

CONTAINS
!  Differentiation of mean in reverse (adjoint) mode (with options i4 dr8 r8):
!   gradient     of useful results: a b
!   with respect to varying inputs: a b
!   RW status of diff variables: a:incr b:in-zero
  SUBROUTINE MEAN_B(a, ad, b, bd)
    IMPLICIT NONE
    real(8), DIMENSION(:), INTENT(INOUT) :: a
    real(8), DIMENSION(:), INTENT(INOUT) :: ad
    real(8), INTENT(INOUT) :: b
    real(8), INTENT(INOUT) :: bd
    real(8) :: temp
    real(8) :: tempd
    real(8) :: n
    INTEGER*8 :: i
    INTRINSIC SIZE
    INTRINSIC REAL
    INTRINSIC INT
    INTEGER*8 :: ad_to
    n = REAL(SIZE(a), 8)
    DO i=1,INT(n)

    END DO
    CALL PUSHINTEGER8(i - 1)
    tempd = bd
    CALL DIVIDE_B(b, bd, n, temp, tempd)
    CALL POPINTEGER8(ad_to)
    DO i=ad_to,1,-1
      tempd = bd
      CALL ADD_B(b, bd, a(i), ad(i), temp, tempd)
    END DO
    bd = 0.0_8
  END SUBROUTINE MEAN_B

END MODULE MOD_MEAN_B