module utils
    use, intrinsic :: ISO_FORTRAN_ENV
    implicit none

    real, parameter :: pi = 3.141592653589793
    integer, parameter :: dp = kind(1.0d0)
    integer, parameter :: lin_binning = 0, log_binning = 1, ihs_binning = 2, sqrt_binning = 3

    private
    public pi, assert_iostat, count_number_of_lines
    public lin_binning, log_binning, ihs_binning, sqrt_binning
    public binning, find_bin_index, create_bins, destroy_bins
    public qsort_arg, qsort_arg_int, qselect
    public distance_function_interface, distance_euclidean, deg2rad, rad2deg, distance_sphere, max_longitude_difference, angles_sphere, rotation_sphere, bearing_sphere, pointing_angle_cos_sin_sphere, distance_to_meridian_sphere, longitude_reach_sphere
    public random_number_int, random_unique_number_int, poisson
    public mean, median, variance, covariance_matrix

    type binning
        real :: x_min, x_max, bin_size = 0.0
        integer :: n_bin = 0
        integer :: spacing
        real :: ihs_theta
        real, allocatable :: bin_edges(:), bin_centers(:), bin_centers_eff(:)
    end type binning

    abstract interface
        function distance_function_interface(x1, y1, x2, y2) result(d)
            implicit none
            real, intent(in) :: x1, y1, x2, y2
            real :: d
        end function
    end interface

    contains

    subroutine assert_iostat(iostat, filename)
        !Arguments
        integer, intent(in) :: iostat
        character(len=*), intent(in) :: filename

        if(iostat /= 0) then
            print "(A, A, A, I5)", "Failed to open ", trim(filename), ". Iostat: ", iostat
            error stop
        end if
    end subroutine assert_iostat

    function count_number_of_lines(filename) result(n)
        implicit none
        character(len=*), intent(in) :: filename
        integer :: n, file_unit, iostat
        character :: c

        open(newunit=file_unit, file=filename, status='old', iostat=iostat)
        if(iostat > 0) then
            print *, "Failed to open file ", filename
            n = -1
            return
        end if

        n = 0
        do
            read(unit=file_unit, fmt=*, iostat=iostat) c
            if(iostat == 0) then
                if(c == '#') then
                    print *, "Deteced comment lines in file ", filename, ". Check your data file."
                    cycle
                end if

                n = n + 1
            else if(iostat < 0) then
                !print *, "Reached end of file."
                exit
            else
                print *, "Error reading file ", filename
                n = -1
                return
            end if
        end do

        close(file_unit)
    end function

    pure elemental function isinh_transform(x, p) result(y)
        !Argument
        real, intent(in) :: x, p
        !Return value
        real :: y

        y = log(p*x + sqrt((p*x)**2 + 1))/p
    end function isinh_transform

    pure elemental function sinh_transform(y, p) result(x)
        !Argument
        real, intent(in) :: y, p
        !Return value
        real :: x

        x = sinh(p*y)/p
    end function sinh_transform

    function find_bin_index(x, bins) result(i)
        real, intent(in) :: x
        type(binning), intent(in) :: bins
        !Variables
        integer :: i
        real :: bin_size, x_trans, x_min_trans

        if(x < bins%x_min .or. x > bins%x_max) then
            i = -1
            return
        else if(x == bins%x_max) then
            i = bins%n_bin
            return
        end if

        if(bins%spacing == lin_binning) then
            i = int((x - bins%x_min)/bins%bin_size) + 1
        else if(bins%spacing == log_binning) then
            x_trans = log10(x)
            x_min_trans = log10(bins%x_min)
            i = int((x_trans - x_min_trans)/bins%bin_size) + 1
        else if(bins%spacing == ihs_binning) then
            x_trans = isinh_transform(x, bins%ihs_theta)
            x_min_trans = isinh_transform(bins%x_min, bins%ihs_theta)
            i = int((x_trans - x_min_trans)/bins%bin_size) + 1
        else if(bins%spacing == sqrt_binning) then
            x_trans = sqrt(x)
            x_min_trans = sqrt(bins%x_min)
            i = int((x_trans - x_min_trans)/bins%bin_size) + 1
        end if

        if(i > bins%n_bin) then
            i = -1
            print *, "Something went wrong during binning."
            print "(A, F, A, F)", "x : ", x, "x_max : ", bins%x_max
        end if
    end function

    subroutine create_bins(x_min, x_max, bin_size, n_bin, p, spacing, bins)
        real, optional, intent(in) :: x_min, x_max, bin_size
        integer, optional, intent(in) :: n_bin
        real, optional, intent(in) :: p
        integer, intent(in) :: spacing
        type(binning), intent(out) :: bins
        !Variables
        integer :: i
        real :: theta

        bins%spacing = spacing
        if(.not. (spacing == lin_binning .or. &
                  spacing == log_binning .or. &
                  spacing == ihs_binning .or. &
                  spacing == sqrt_binning)) then
            print *, "Bin spacing unknown:", spacing
            error stop
        end if
        if(spacing == ihs_binning) then
            theta = 1.0
            if(present(p)) theta = p
            bins%ihs_theta = theta
        end if

        if(present(n_bin)) then
            bins%n_bin = n_bin
        else if(present(x_min) .and. present(x_max) .and. present(bin_size) .and. .not. present(n_bin)) then
            if(spacing == lin_binning) then
                bins%n_bin = (x_max - x_min)/bin_size
            else if(spacing == log_binning) then
                bins%n_bin = (log10(x_max) - log10(x_min))/bin_size
            else if(spacing == ihs_binning) then
                bins%n_bin = (isinh_transform(x_max, theta) - isinh_transform(x_min, theta))/bin_size
            else if(spacing == sqrt_binning) then
                bins%n_bin = (sqrt(x_max) - sqrt(x_min))/bin_size
            end if
        else
            print *, "Binning is ill-defined."
            error stop
        end if

        allocate(bins%bin_edges(bins%n_bin+1), bins%bin_centers(bins%n_bin))

        if(present(x_min) .and. present(x_max) .and. present(n_bin) .and. .not. present(bin_size)) then
            bins%x_min = x_min
            bins%x_max = x_max
            if(spacing == lin_binning) then
                bins%bin_size = (x_max - x_min)/n_bin
            else if(spacing == log_binning) then
                bins%bin_size = (log10(x_max) - log10(x_min))/n_bin
            else if(spacing == ihs_binning) then
                bins%bin_size = (isinh_transform(x_max, theta) - isinh_transform(x_min, theta))/n_bin
            else if(spacing == sqrt_binning) then
                bins%bin_size = (sqrt(x_max) - sqrt(x_min))/n_bin
            end if
        else if(present(x_min) .and. present(bin_size) .and. present(n_bin) .and. .not. present(x_max)) then
            bins%x_min = x_min
            bins%bin_size = bin_size
            if(spacing == lin_binning) then
                bins%x_max = x_min +  bin_size*n_bin
            else if(spacing == log_binning) then
                bins%x_max = 10**(log10(x_min) +  bin_size*n_bin)
            else if(spacing == ihs_binning) then
                bins%x_max = sinh_transform(isinh_transform(x_min, theta) +  bin_size*n_bin, theta)
            else if(spacing == sqrt_binning) then
                bins%x_max = (sqrt(x_min) +  bin_size*n_bin)**2
            end if
        else
            print *, "Binning is ill-defined."
            error stop
        end if

        bins%bin_edges(bins%n_bin+1) = bins%x_max
        if(spacing == lin_binning) then
            do i=1, bins%n_bin
                bins%bin_edges(i) = bins%x_min + bins%bin_size * (i-1)
            end do
        else if(spacing == log_binning) then
            do i=1, bins%n_bin
                bins%bin_edges(i) = 10.0**(log10(bins%x_min) + bins%bin_size * (i-1))
            end do
        else if(spacing == ihs_binning) then
            do i=1, bins%n_bin
                bins%bin_edges(i) = sinh_transform(isinh_transform(bins%x_min, theta) + bins%bin_size * (i-1), theta)
            end do
        else if(spacing == sqrt_binning) then
            do i=1, bins%n_bin
                bins%bin_edges(i) = (sqrt(bins%x_min) + bins%bin_size * (i-1))**2
            end do
        end if
        bins%bin_centers = bins%bin_edges(1:bins%n_bin) + (bins%bin_edges(2:bins%n_bin+1) - bins%bin_edges(1:bins%n_bin))/2.0
    end subroutine create_bins

    subroutine destroy_bins(bins)
        type(binning) :: bins

        if(allocated(bins%bin_edges)) deallocate(bins%bin_edges)
        if(allocated(bins%bin_centers)) deallocate(bins%bin_centers)
    end subroutine destroy_bins

    subroutine qsort_arg(array, order, reverse)
        !Arguments
        real, dimension(:), intent(in) :: array
        integer, dimension(:), intent(out) :: order
        logical, optional, intent(in) :: reverse
        !Variables
        real, allocatable, dimension(:) :: work_array
        integer :: i

        do i=1,size(array)
            order(i) = i
        end do

        allocate(work_array(size(array)), source=array)

        call qsort_func(1, size(array))

        if(present(reverse)) then
            if(reverse) order = order(size(array):1:-1)
        end if

        deallocate(work_array)

        contains
        recursive subroutine qsort_func(l, r)
            integer, intent(in) :: l, r
            integer :: i, j, tmp_idx
            real :: tmp, pivot

            pivot = work_array((l+r)/2)
            i = l-1
            j = r+1

            do
                do
                    j = j-1
                    if (work_array(j) <= pivot) exit
                end do
                do
                    i = i+1
                    if (work_array(i) >= pivot) exit
                end do
                if (i < j) then
                    tmp = work_array(i)
                    work_array(i) = work_array(j)
                    work_array(j) = tmp
                    tmp_idx = order(i)
                    order(i) = order(j)
                    order(j) = tmp_idx
                else if(i == j) then
                    i = i + 1
                    exit
                else
                    exit
                endif
            end do

            if(l < j) call qsort_func(l, j)
            if(i < r) call qsort_func(i, r)
        end subroutine qsort_func
    end subroutine qsort_arg

    subroutine qsort_arg_int(array, order, reverse)
        !Arguments
        integer, dimension(:), intent(in) :: array
        integer, dimension(:), intent(out) :: order
        logical, optional, intent(in) :: reverse
        !Variables
        integer, allocatable, dimension(:) :: work_array
        integer :: i

        do i=1,size(array)
            order(i) = i
        end do

        allocate(work_array(size(array)), source=array)

        call qsort_func(1, size(array))

        if(present(reverse)) then
            if(reverse) order = order(size(array):1:-1)
        end if

        deallocate(work_array)

        contains
        recursive subroutine qsort_func(l, r)
            integer, intent(in) :: l, r
            integer :: i, j, tmp_idx
            integer :: tmp, pivot

            pivot = work_array((l+r)/2)
            i = l-1
            j = r+1

            do
                do
                    j = j-1
                    if (work_array(j) <= pivot) exit
                end do
                do
                    i = i+1
                    if (work_array(i) >= pivot) exit
                end do
                if (i < j) then
                    tmp = work_array(i)
                    work_array(i) = work_array(j)
                    work_array(j) = tmp
                    tmp_idx = order(i)
                    order(i) = order(j)
                    order(j) = tmp_idx
                else if(i == j) then
                    i = i + 1
                    exit
                else
                    exit
                endif
            end do

            if(l < j) call qsort_func(l, j)
            if(i < r) call qsort_func(i, r)
        end subroutine qsort_func
    end subroutine qsort_arg_int

    pure function qselect(array, k) result(k_value)
        !Arguments
        real, dimension(:), intent(in) :: array
        integer, intent(in) :: k
        !Return value
        real :: k_value
        !Variables
        real, dimension(:), allocatable :: work_array

        allocate(work_array(size(array)), source=array)
        call quickselect(work_array, 1, size(array), k, k_value)

        contains
            pure recursive subroutine quickselect(array, l, r, k, k_value)
                !Arguments
                real, dimension(:), intent(inout) :: array
                integer, intent(in) :: l, r, k
                real, intent(out) :: k_value
                !Variables
                integer :: pivot_index

                do while(.true.)
                    if(l == r) then
                        k_value = array(l)
                        exit
                    end if
                    call partition(array, l, r, int((l+r)/2), pivot_index)
                    if(k == pivot_index) then
                        k_value = array(k)
                        exit
                    else if( k < pivot_index) then
                        call quickselect(array, l, r-1, k, k_value)
                        exit
                    else
                        call quickselect(array, l+1, r, k, k_value)
                        exit
                    end if
                end do
            end subroutine

            pure subroutine swap(array, i, j)
                !Arguments
                real, dimension(:), intent(inout) :: array
                integer, intent(in) :: i, j
                !Variables
                real :: tmp

                tmp = array(j)
                array(j) = array(i)
                array(i) = tmp
            end subroutine swap

            pure subroutine partition(array, l, r, pivot_index, k)
                !Arguments
                real, dimension(:), intent(inout) :: array
                integer, intent(in) :: l, r, pivot_index
                integer, intent(out) :: k
                !Variables
                real :: pivot_value
                integer :: i

                pivot_value = array(pivot_index)
                call swap(array, pivot_index, r)
                k = l
                do i=l, r-1
                    if(array(i) < pivot_value) then
                        call swap(array, i, k)
                        k = k+1
                    end if
                end do
                call swap(array, r, k)
            end subroutine partition
    end function qselect

    function poisson(mu) result(x)
        !Arguments
        real, intent(in) :: mu
        !Result
        integer :: x
        !Variables
        real :: sum, prod, u

        x = 0
        prod = exp(-mu)
        sum = prod
        call random_number(u)
        do while (u > sum)
            x = x + 1
            prod = prod * mu/x
            sum = sum + prod
        end do
    end function poisson

    pure elemental function distance_euclidean(x1, y1, x2, y2) result(d)
        !Arguments
        real, intent(in) :: x1, y1, x2, y2
        !Result
        real :: d

        d = sqrt((x1-x2)**2 + (y1-y2)**2)
    end function distance_euclidean

    pure elemental function deg2rad(deg) result(rad)
        !Argument
        real, intent(in) :: deg
        !Result
        real :: rad

        rad = deg/180.0*pi
    end function deg2rad

    pure elemental function rad2deg(rad) result(deg)
        !Argument
        real, intent(in) :: rad
        !Result
        real :: deg

        deg = rad*180.0/pi
    end function rad2deg

    pure elemental subroutine rotation_sphere(lambda, phi, lambda_rot, phi_rot, lambda_out, phi_out)
        !Arguments
        real, intent(in) :: lambda, phi, lambda_rot, phi_rot
        real, intent(out) :: lambda_out, phi_out
        !Varaibles
        real :: sigma, theta, theta_rot, x, y, z, tan_lambda_out, cos_phi_out

        !Azimuthal angle: phi, ploar angle: theta
        sigma = lambda + lambda_rot
        theta = pi/2.0 - phi
        theta_rot = -phi_rot
        x = cos(sigma)*cos(theta_rot)*sin(theta) + cos(theta)*sin(theta_rot)
        y = sin(sigma)*sin(theta)
        z = -cos(sigma)*sin(theta_rot)*sin(theta) + cos(theta)*cos(theta_rot)
        lambda_out = atan(y/x)
        if(x < 0.0) then
            lambda_out = lambda_out + pi
        end if

        if(z >= 1.0) then
            phi_out = pi/2.0
        else if(z <= -1.0) then
            phi_out = -pi/2.0
        else
            phi_out = pi/2.0 - acos(z)
        end if
    end subroutine rotation_sphere

    elemental function distance_sphere(lambda1, phi1, lambda2, phi2) result(d)
        !Arguments
        real, intent(in) :: phi1, lambda1, phi2, lambda2
        !Result
        real :: d
        !Variables
        real :: cos_d

        cos_d = sin(phi1)*sin(phi2) + cos(phi1)*cos(phi2)*cos(lambda2-lambda1)
        if(cos_d >= 1.0) then
            d = 0.0
        else if(cos_d <= -1.0) then
            d = pi
        else
            d = acos(cos_d)
        end if
    end function distance_sphere

    elemental function max_longitude_difference(lambda1, phi1, d) result(Delta_lambda)
        !Arguments
        real, intent(in) :: phi1, lambda1, d
        !Result
        real :: Delta_lambda
        !Variables
        real :: cos_d, sin_phi1, sin_phi2, cos_phi2, cos_Delta_lambda

        cos_d = cos(d)
        sin_phi1 = sin(phi1)
        sin_phi2 = sin_phi1/cos_d
        cos_phi2 = sqrt(1.0 - sin_phi2**2)
        cos_Delta_lambda = (cos_d - sin_phi1*sin_phi2)/(cos(phi1)*cos_phi2)
        if(cos_Delta_lambda >= 1.0) then
            Delta_lambda = 0.0
        else if(cos_d <= -1.0) then
            Delta_lambda = pi
        else
            Delta_lambda = acos(cos_Delta_lambda)
        end if
    end function max_longitude_difference

    elemental function bearing_sphere(lambda1, phi1, lambda2, phi2) result(alpha)
        !Arguments
        real, intent(in) :: phi1, lambda1, phi2, lambda2
        !Result
        real :: alpha
        !Variables
        real :: x, y, cos_phi2

        cos_phi2 = cos(phi2)
        y = cos_phi2 * sin(lambda2-lambda1)
        x = cos(phi1)*sin(phi2) - sin(phi1)*cos_phi2*cos(lambda2-lambda1)
        alpha = atan2(y,x)
    end function bearing_sphere

    pure function pointing_angle_cos_sin_sphere(lambda1, phi1, lambda2, phi2, distance) result(cos_sin)
        !Arguments
        real, intent(in) :: phi1, lambda1, phi2, lambda2, distance
        !Result
        real :: cos_sin(2)
        !Variables
        real :: sin_d

        sin_d = sin(distance)
        cos_sin(1) = sin(lambda2-lambda1)*cos(phi2)/sin_d
        cos_sin(2) = (sin(phi2)-sin(phi1)*cos(distance))/(cos(phi1)*sin_d)
    end function pointing_angle_cos_sin_sphere

    elemental function distance_to_meridian_sphere(lambda1, phi1, lambda2) result(distance)
        !Arguments
        real, intent(in) :: phi1, lambda1, lambda2
        !Result
        real :: distance
        !Variables
        real :: sin_distance

        sin_distance = abs(sin(lambda2-lambda1)*cos(phi1))
        if(abs(lambda2-lambda1) <= pi/2.0) then
            !Meridian is closer than poles
            if(sin_distance >= 1.0) then
                distance = pi/2.0
            else
                distance = asin(sin_distance)
            end if
        else
            !Poles are closer
            distance = pi/2.0 - abs(phi1)
        end if
    end function distance_to_meridian_sphere

    elemental function longitude_reach_sphere(phi1, distance) result(Delta_lambda)
        !Arguments
        real, intent(in) :: phi1, distance
        !Result
        real :: Delta_lambda
        !Variables
        real :: sin_Delta_lambda

        sin_Delta_lambda = abs(sin(distance)/cos(phi1))
        if(sin_Delta_lambda >= 1.0) then
            Delta_lambda = pi/2.0
        else
            Delta_lambda = asin(sin_Delta_lambda)
        end if
    end function longitude_reach_sphere

    pure function angles_sphere(lambda1, phi1, lambda2, phi2, distance) result(cos_sin)
        !Arguments
        real, intent(in) :: phi1, lambda1, phi2, lambda2
        real, optional, intent(in) :: distance
        !Result
        real :: cos_sin(2)
        !Variables
        real :: d, sin_d, cos_phi2

        if(present(distance)) then
            d = distance
        else
            d = distance_sphere (lambda1, phi1, lambda2, phi2)
        end if

        sin_d = sin(d)
        cos_phi2 = cos(phi2)
        !cos theta
        cos_sin(1) = cos_phi2/sin_d * sin(lambda2-lambda1)
        !sin theta
        cos_sin(2) = (cos(phi1)*sin(phi2) - sin(phi1)*cos_phi2*cos(lambda2-lambda1))/sin_d
    end function angles_sphere

    subroutine random_number_int(array, max, min)
        !Arguments
        integer, intent(out) :: array(:)
        integer, intent(in) :: max
        integer, optional, intent(in) :: min
        !Variables
        integer :: i, min_number
        real :: rand

        if(present(min)) then
            min_number = min
        else
            min_number = 0
        endif

        do i=1,size(array)
            call random_number(rand)
            array(i) = int((max-min_number+1)*rand) + min_number
        end do
    end subroutine random_number_int

    subroutine random_unique_number_int(array, max, min)
        !Arguments
        integer, intent(out) :: array(:)
        integer, intent(in) :: max
        integer, optional, intent(in) :: min
        !Variables
        integer :: min_number, N, n_sample, m, t
        real :: u

        if(present(min)) then
            min_number = min
        else
            min_number = 0
        endif

        !Algorithm 3.4.2S from Knuth's book Seminumeric Algorithms
        N = max + 1 - min_number
        n_sample = size(array)
        if(n_sample > N - 1) then
            print "(A, I, A, I, A, I, A)", "Cannot draw ", n_sample, " unique numbers from the interval [", min_number, ",", max,"]."
            return
        end if
        m = 0
        t = 0

        do while(m < n_sample)
            call random_number(u)
            if( (N-t)*u >= n_sample-m) then
                t = t+1
            else
                array(m+1) = t
                t = t+1
                m = m+1
            end if
        end do
        array = array + min_number
    end subroutine random_unique_number_int

    pure function mean(x) result(m)
        !Arguments
        real, dimension(:), intent(in) :: x
        !Returns
        real :: m
        !Variables
        real :: n

        n = size(x)
        m = sum(x)/n
    end function mean

    pure function median(x) result(m)
        !Arguments
        real, dimension(:), intent(in) :: x
        !Returns
        real :: m
        !Variables
        integer :: n

        n = size(x)
        if(modulo(n, 2) == 0) then
            m = (qselect(x, n/2+1) + qselect(x, n/2))/2
        else
            m = qselect(x, n/2+1)
        end if
    end function median

    pure function variance(x) result(var)
        !Arguments
        real, dimension(:), intent(in) :: x
        !Returns
        real :: var
        !Variables
        real :: n, mean

        n = size(x)
        if(n <= 1) then
            var = 0.0
            return
        end if
        mean = sum(x)/n
        var = sum((x-mean)**2)/(n-1)
    end function variance

    subroutine covariance_matrix(x, cov)
        !Arguments
        real, intent(in) :: x(:,:)
        real, intent(out) :: cov(:,:)
        !Variables
        integer :: i, j, n_samples, n_data
        real :: mean_i, mean_j

        n_samples = size(x, dim=1)
        n_data = size(x, dim=2)

        do i=1,n_data
            mean_i = sum(x(:,i))/n_samples
            do j=1,i
                mean_j = sum(x(:,j))/n_samples
                cov(i,j) = sum((x(:,i)-mean_i)*(x(:,j)-mean_j))/(n_samples-1)
                cov(j,i) = cov(i,j)
            end do
        end do
    end subroutine covariance_matrix

end module utils


!   linsolve.f
!   Use Scalapack and MPI to solve a system of linear equations
!   on a virtual rectangular grid of processes.
!
!   Input:
!       N: order of linear system
!       NPROC_ROWS: number of rows in process grid
!       NPROC_COLS: number of columns in process grid
!       ROW_BLOCK_SIZE:  blocking size for matrix rows
!       COL_BLOCK_SIZE:  blocking size for matrix columns
!
!   Output:
!       Input data, error in solution, and time to solve system.
!
!   Algorithm:
!     1.  Initialize MPI and BLACS.
!       2.  Get process rank (MY_RANK) and total number of
!           processes (NP).   Use both BLACS and MPI.
!       3a. Process 0 read and broadcast matrix order (N),
!           number of process rows (NPROC_ROWS), number
!           of process columns (NPROC_COLS), ROW_BLOCK_SIZE,
!         and COL_BLOCK_SIZE.
!       3b. Process != 0 receive same.
!       4.  Use BLACS_GRIDINIT to set up process grid.
!       5.  Compute amount of storage needed for local arrays.
!       6.  Use ScaLAPACK routine DESCINIT to initialize
!           descriptors for A, EXACT (= exact solution), and B.
!       7.  Use random number generator to generate contents
!           of local block of matrix (A_LOCAL).
!       8.  Set entries of EXACT to 1.0.
!     9.  Generate B by computing B = A*EXACT.  Use
!           PBLAS routine PSGEMV.
!      10.  Solve linear system by call to ScaLAPACK routine
!           PSGESV (solution returned in B).
!      11.  Use PBLAS routines PSAXPY and PSNRM2 to compute
!           the norm of the error ||B - EXACT||_2.
!      12.  Process 0 print results.
!      13.  Free up storage, shutdown BLACS and MPI.
!
!   Notes:
!       1.  The vectors EXACT, and B are significant only
!           in the first process column.
!       2.  A_LOCAL is allocated as a linear array.
!       3.  The solver only allows square blocks.  So we
!           read in a single value, BLOCK_SIZE, and assign
!           it to ROW_BLOCK_SIZE and COL_BLOCK_SIZE.  Thus,
!           since the matrix is square, NPROC_ROWS = NPROC_COLS.
!
      PROGRAM LINSOLVE
      INCLUDE 'mpif.h'
!
!   Constants
      INTEGER           MAX_VECTOR_SIZE
      INTEGER           MAX_MATRIX_SIZE
      INTEGER           DESCRIPTOR_SIZE
      PARAMETER (MAX_VECTOR_SIZE = 1000)
      PARAMETER   (MAX_MATRIX_SIZE = 250000)
      PARAMETER   (DESCRIPTOR_SIZE = 10)
!
!   Array Variables
      REAL        B_LOCAL(MAX_VECTOR_SIZE)
      INTEGER           B_DESCRIP(DESCRIPTOR_SIZE)
!
      REAL        EXACT_LOCAL(MAX_VECTOR_SIZE)
      INTEGER           EXACT_DESCRIP(DESCRIPTOR_SIZE)
!
      REAL        A_LOCAL(MAX_MATRIX_SIZE)
      INTEGER           A_DESCRIP(DESCRIPTOR_SIZE)
      INTEGER           PIVOT_LIST(MAX_VECTOR_SIZE)
!
!   Scalar Variables
      INTEGER     NP
      INTEGER           MY_RANK
      INTEGER           NPROC_ROWS
      INTEGER           NPROC_COLS
      INTEGER           IERROR
      INTEGER           M, N
      INTEGER           ROW_BLOCK_SIZE
      INTEGER           COL_BLOCK_SIZE
        INTEGER         INPUT_DATA_TYPE
        INTEGER         BLACS_CONTEXT
        INTEGER         TEMP_CONTEXT
        INTEGER         LOCAL_MAT_ROWS
        INTEGER         LOCAL_MAT_COLS
      INTEGER           EXACT_LOCAL_SIZE
      INTEGER           B_LOCAL_SIZE
      INTEGER           I, J
      INTEGER           MY_PROCESS_ROW
      INTEGER           MY_PROCESS_COL
        REAL            ERROR_2
      DOUBLE PRECISION START_TIME
      DOUBLE PRECISION ELAPSED_TIME
!
!   Local Functions
!       REAL            RAND_VAL
!
!   External subroutines
!     MPI:
!      EXTERNAL    MPI_INIT, MPI_COMM_SIZE, MPI_COMM_RANK
!      EXTERNAL    MPI_BCAST, MPI_ABORT
!      EXTERNAL    MPI_BARRIER, MPI_FINALIZE
!     BLACS:
!      EXTERNAL    BLACS_GET, BLACS_GRIDINIT, BLACS_PCOORD
!      EXTERNAL    BLACS_EXIT
!     PBLAS:
!      EXTERNAL    PSGEMV, PSAXPY, PSNRM2
!     ScaLAPACK
!      EXTERNAL    DESCINIT, PSGESV
!     System
!      EXTERNAL    SLARNV
!
!   External functions
!     ScaLAPACK:
      INTEGER           NUMROC
!      EXTERNAL    NUMROC
      INTEGER IAM,NPROCS
!
!   Junk Variables
      INTEGER           ISEED(4)
!
!   Begin Executable Statements
!
!   Initialize MPI and BLACS
      CALL MPI_INIT(IERROR)
!
      CALL MPI_COMM_SIZE(MPI_COMM_WORLD, NP, IERROR)
      CALL MPI_COMM_RANK(MPI_COMM_WORLD, MY_RANK, IERROR)
!      CALL BLACS_PINFO(IAM, NPROCS)
!
!
!   Get Input Data.
      IF (MY_RANK.EQ.0) THEN
          READ(5,*) N, NPROC_ROWS, NPROC_COLS, ROW_BLOCK_SIZE,COL_BLOCK_SIZE
      END IF
      CALL MPI_BCAST(N,              1, MPI_INTEGER, 0, MPI_COMM_WORLD, IERROR)
      CALL MPI_BCAST(NPROC_ROWS,     1, MPI_INTEGER, 0, MPI_COMM_WORLD, IERROR)
      CALL MPI_BCAST(NPROC_COLS,     1, MPI_INTEGER, 0, MPI_COMM_WORLD, IERROR)
      CALL MPI_BCAST(ROW_BLOCK_SIZE, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, IERROR)
      CALL MPI_BCAST(COL_BLOCK_SIZE, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, IERROR)
      IF (NP.LT.(NPROC_ROWS*NPROC_COLS)) THEN
          WRITE(6,250) MY_RANK, NP, NPROC_ROWS, NPROC_COLS
  250     FORMAT(' ','Proc ',I2,' > NP = ',I2,', NPROC_ROWS = ',I2,', NPROC_COLS = ',I2)
          WRITE(6,260)
  260       FORMAT(' ','Need more processes!  Quitting.')
          CALL MPI_ABORT(MPI_COMM_WORLD, -1, IERROR)
        END IF

!
!   The matrix is square
        M = N
!
!
!   Build BLACS grid.
!     First get BLACS System Context (in TEMP_CONTEXT(1))
      CALL BLACS_GET(0, 0, BLACS_CONTEXT)
!      BLACS_CONTEXT = TEMP_CONTEXT
!
!     BLACS_CONTEXT is in/out.
!     'R': process grid will use row major ordering.
      CALL BLACS_GRIDINIT(BLACS_CONTEXT,'Row',NPROC_ROWS,NPROC_COLS)
!
!
!   Figure out how many rows and cols we'll need in the local
!     matrix.
      CALL BLACS_PCOORD(BLACS_CONTEXT, MY_RANK, MY_PROCESS_ROW,MY_PROCESS_COL)
      LOCAL_MAT_ROWS = NUMROC(M, ROW_BLOCK_SIZE, MY_PROCESS_ROW,0, NPROC_ROWS)
      LOCAL_MAT_COLS = NUMROC(N, COL_BLOCK_SIZE, MY_PROCESS_COL,0, NPROC_COLS)
      IF (LOCAL_MAT_ROWS*LOCAL_MAT_COLS.GT.MAX_MATRIX_SIZE) THEN
          WRITE(6,290) MY_RANK, LOCAL_MAT_ROWS, LOCAL_MAT_COLS,MAX_MATRIX_SIZE
  290       FORMAT(' ','Proc ',I2, &
                     ' > LOCAL_MAT_ROWS = ',I5, &
                     ', LOCAL_MAT_COLS = ',I5, &
                     ', MAX_MATRIX_SIZE = ',I6)
          WRITE(6,292)
  292       FORMAT(' ','Insufficient storage!  Quitting.')
          CALL MPI_ABORT(MPI_COMM_WORLD, -1, IERROR)
      END IF
!
! Now figure out storage for B_LOCAL and EXACT_LOCAL
      B_LOCAL_SIZE = NUMROC(M, ROW_BLOCK_SIZE, MY_PROCESS_ROW,0, NPROC_ROWS)
      IF (B_LOCAL_SIZE.GT.MAX_VECTOR_SIZE) THEN
          WRITE(6,294) MY_RANK, B_LOCAL_SIZE, MAX_VECTOR_SIZE
  294       FORMAT(' ','Proc ',I2,' > B_LOCAL_SIZE = ',I5,', MAX_VECTOR_SIZE = ',I5)
          WRITE(6,296)
  296       FORMAT(' ','Insufficient storage!  Quitting.')
          CALL MPI_ABORT(MPI_COMM_WORLD, -1, IERROR)
      END IF
!
      EXACT_LOCAL_SIZE = NUMROC(N, COL_BLOCK_SIZE, MY_PROCESS_ROW,0, NPROC_ROWS)
      IF (EXACT_LOCAL_SIZE.GT.MAX_VECTOR_SIZE) THEN
          WRITE(6,298) MY_RANK, EXACT_LOCAL_SIZE, MAX_VECTOR_SIZE
  298       FORMAT(' ','Proc ',I2,' > EXACT_LOCAL_SIZE = ',I5,', MAX_VECTOR_SIZE = ',I5)
          WRITE(6,299)
  299       FORMAT(' ','Insufficient storage!  Quitting.')
        write(*,*)"calling abort"
          CALL MPI_ABORT(MPI_COMM_WORLD, -1, IERROR)
      END IF
!
!
! Now build the matrix descriptors
      CALL DESCINIT(A_DESCRIP, M, N, ROW_BLOCK_SIZE, &
                    COL_BLOCK_SIZE, 0, 0, BLACS_CONTEXT, &
                    LOCAL_MAT_ROWS, IERROR)
      IF (IERROR.NE.0) THEN
            WRITE(6,300) MY_RANK, IERROR
  300       FORMAT(' ','Proc ',I2,' > DESCINIT FOR A FAILED, IERROR = ',I3)
            CALL MPI_ABORT(MPI_COMM_WORLD, -1, IERROR)
        END IF
!
        CALL DESCINIT(B_DESCRIP, M, 1, ROW_BLOCK_SIZE, 1, &
                      0, 0, BLACS_CONTEXT, B_LOCAL_SIZE, &
                      IERROR)
      IF (IERROR.NE.0) THEN
            WRITE(6,350) MY_RANK, IERROR
  350       FORMAT(' ','Proc ',I2,' > DESCINIT FOR B FAILED, IERROR = ',I3)
            CALL MPI_ABORT(MPI_COMM_WORLD, -1, IERROR)
        END IF
!
        CALL DESCINIT(EXACT_DESCRIP, N, 1, COL_BLOCK_SIZE, 1, &
                      0, 0, BLACS_CONTEXT, EXACT_LOCAL_SIZE, &
                      IERROR)
      IF (IERROR.NE.0) THEN
            WRITE(6,400) MY_RANK, IERROR
  400       FORMAT(' ','Proc > ',I2,' > DESCINIT FOR EXACT FAILED, IERROR = ',I3)
            CALL MPI_ABORT(MPI_COMM_WORLD, -1, IERROR)
        END IF
!
!
!   Now initialize A_LOCAL and EXACT_LOCAL
!     CALL SEED(MY_RANK)
!     DO 600 J = 0, LOCAL_MAT_COLS - 1
!         DO 500 I = 1, LOCAL_MAT_ROWS
!           A_LOCAL(LOCAL_MAT_ROWS*J + I) = RAND_VAL()
!  500          CONTINUE
!  600  CONTINUE
!     SGI subroutine -- generates the full matrix
      ISEED(1) = MY_RANK
        ISEED(2) = MY_RANK*MY_RANK
        ISEED(3) = NP - MY_RANK
        ISEED(4) = 2*MY_RANK + 1
      DO 650 J = 0, LOCAL_MAT_COLS - 1
            CALL SLARNV(1, ISEED, LOCAL_MAT_ROWS, &
                        A_LOCAL(J*LOCAL_MAT_ROWS + 1))
  650 CONTINUE
!
      DO 700 I = 1, EXACT_LOCAL_SIZE
          EXACT_LOCAL(I) = 1.0
  700 CONTINUE
!
!
!   Use PBLAS function PSGEMV to compute right-hand side B = A*EXACT
!     'N': Multiply by A -- not A^T or A^H
      CALL PSGEMV('N', M, N, 1.0, A_LOCAL, 1, 1, A_DESCRIP, &
                   EXACT_LOCAL, 1, 1, EXACT_DESCRIP, 1, 0.0, &
                   B_LOCAL, 1, 1, B_DESCRIP, 1)
!
!
!   Done with setup!  Solve the system.
      CALL MPI_BARRIER(MPI_COMM_WORLD, IERROR)
      START_TIME = MPI_WTIME()
      CALL PSGESV(N, 1, A_LOCAL, 1, 1, A_DESCRIP, PIVOT_LIST, &
                        B_LOCAL, 1, 1, B_DESCRIP, IERROR)
      ELAPSED_TIME = MPI_WTIME() - START_TIME
      IF (IERROR.NE.0) THEN
            WRITE(6,800) MY_RANK, IERROR
  800       FORMAT(' ','Proc ',I2,' > PSGESV FAILED, IERROR = ',I3)
            CALL MPI_ABORT(MPI_COMM_WORLD, -1, IERROR)
        END IF
!
!     WRITE(6,850) MY_RANK, (B_LOCAL(J), J = 1, B_LOCAL_SIZE)
! 850   FORMAT(' ','Proc ',I2,' > B = ',F6.3,' ',F6.3,' ',F6.3,' ', &
!             F6.3,' ',F6.3,' ',F6.3,' ',F6.3,' ',F6.3,' ',F6.3,' ', &
!             F6.3)
!     WRITE(6,860) MY_RANK, (EXACT_LOCAL(I), I = 1, EXACT_LOCAL_SIZE)
! 860   FORMAT(' ','Proc ',I2,' > EXACT = ',F6.3,' ',F6.3,' ',F6.3,' ', &
!             F6.3,' ',F6.3,' ',F6.3,' ',F6.3,' ',F6.3,' ',F6.3,' ', &
!             F6.3)
!
!   Now find the norm of the error.
!     First compute EXACT = -1*B + EXACT
        CALL PSAXPY(N, -1.0, B_LOCAL, 1, 1, B_DESCRIP, 1, &
                    EXACT_LOCAL, 1, 1, EXACT_DESCRIP, 1)
!     Now compute 2-norm of EXACT
      CALL PSNRM2(N, ERROR_2, EXACT_LOCAL, 1, 1, EXACT_DESCRIP, 1)
!
!
      IF (MY_RANK.EQ.0) THEN
          WRITE(6,900) N, NP
  900       FORMAT(' ','N = ',I4,', Number of Processes = ',I2)
          WRITE(6,950) NPROC_ROWS, NPROC_COLS
  950     FORMAT(' ','Process rows = ',I2,', Process cols = ',I2)
          WRITE(6,1000) ROW_BLOCK_SIZE, COL_BLOCK_SIZE
 1000     FORMAT(' ','Row block size = ',I3,', Col block size = ',I3)
          WRITE(6,1100) ERROR_2
 1100     FORMAT(' ','2-Norm of error = ',E13.6)
          WRITE(6,1200) 1000.0*ELAPSED_TIME
 1200     FORMAT(' ','Elapsed time = ',D13.6,' milliseconds')
        END IF
!
!
!   Now free up allocated resources and shut down
!     Call BLACS_EXIT.  Argument != 0 says, "I'll shut down MPI."
      CALL BLACS_EXIT(1)
        CALL MPI_FINALIZE(IERROR)
!
      STOP
!
!     End of Main Program LINSOLVE
      END
!
!


!**********************************************************************
!    LICENSED MATERIALS - PROPERTY OF IBM                             *
!    "RESTRICTED MATERIALS OF IBM"                                    *
!                                                                     *
!    5765-422                                                         *
!    (C) COPYRIGHT IBM CORP. 1995. ALL RIGHTS RESERVED.               *
!                                                                     *
!    U.S. GOVERNMENT USERS RESTRICTED RIGHTS - USE, DUPLICATION       *
!    OR DISCLOSURE RESTRICTED BY GSA ADP SCHEDULE CONTRACT WITH       *
!    IBM CORP.                                                        *
!**********************************************************************
      module diffusion
!
!   Purpose: Assign problem parameters and initial data.
!
!   Routines called:
!       none
!
      use parameters
      use scale
      implicit none
      private
!
! Make all entities private by default.
! Have all public entities have the prefix dif_.
!
!  The following are the publically available routines.
!
      public init_diffusion, init_temp, diff_coef

!
!     The following are publically available variables.
!

      real, public :: dif_ly_ratio
      integer, public :: dif_nx, dif_ny, dif_npts, dif_ntemps
      real(long), public :: dif_delta_t
      real(long), public, allocatable :: dif_x(:), dif_y(:)

!
!     dif_ly_ratio  is the ratio of the x and y lengths of the beam.
!     dif_nx        is the number of sine expansion coefficients to use
!                   in the x direction.
!     dif_ny        is the number of sine expansion coefficients to use
!                   in the y direction.
!     dif_delta_t   is the size of the time step to be display on output.
!     dif_ntemps    is the total number of temperatures to display per point.
!     dif_npts      is the total number of points to output.
!     dif_x         is the x coordinates of the points.
!     dif_y         is the y coordinates of the points.
!
!

!
!     Private variables
!
      integer :: init_f=1, diff_f=1
!   init_f chooses the functional form of initial distribution of temperature.
!   diff_f chooses the functional form for spatially dependent head diffusion
!          coefficient.

      contains

!****************************************************************************!
!*                                                                          *!
!*   Module routine init_diffusion                                          *!
!*                                                                          *!
!*   Purpose: Initialize problem size, number of output point and           *!
!*            functional form of diffusion constant and initial temperature *!
!*            distribution                                                  *!
!*                                                                          *!
!****************************************************************************!
        subroutine init_diffusion
        namelist /input/ ly_ratio, delta_t, numx, numy, nx, ny, numt,         &
     &                    init_f, diff_f
        integer :: numx=5, numy=5, nx=7, ny=7, numt=20
        real(long) :: ly_ratio=1.d0, delta_t=0.1
        real(long) :: delx, dely
        integer :: i, j, ij
        logical :: ex
!==============================================================================!
!          Start of executable code                                            !

        inquire ( file='diffus.naml', exist=ex)
        if( ex ) then
          open( 10, file='diffus.naml', action='read')
          read( 10, input)
          close(10)
        endif

        dif_ly_ratio = ly_ratio
        dif_npts = numx*numy
        dif_delta_t = delta_t
        dif_ntemps  = numt
        dif_nx = nx
        dif_ny = ny
        allocate( dif_x(numx*numy) )
        allocate( dif_y(numy*numx) )
!
! Assign a simple linear array of points.
!
        delx = PI/ ( numx + 1.d0)
        dely = PI/ ( numy + 1.d0)
        do i = 1, numx
          do j = 1, numy
            ij = numx*(j-1)  + i
            dif_x(ij) = delx* i
            dif_y(ij) = dely * j
          enddo
        enddo
        return
        end subroutine init_diffusion

!****************************************************************************!
!*                                                                          *!
!*   Module routine init_temp                                               *!
!*                                                                          *!
!*   Purpose: Return the initial temperature of the bar at a particular     *!
!*            point                                                         *!
!*                                                                          *!
!****************************************************************************!
        function init_temp(x, y)
!
!     Arguments:
!       x: real*8 (in), x coordinate
!       y: real*8 (in), y coordinate
!     Function return:
!     init_temp: real*8 (out), initial temperature at (x,y)
!
        real(long), intent(in) :: x, y
        real(long) :: init_temp

!
!   The problem has been scaled to go from 0 to pi in both the x
!   and y directions. To calculate the expansion coefficients, we
!   define the function to be odd about pi and use the range 0 < x < 2*pi
!
!  Local variables.
        integer :: isign
        real(long) :: x1, y1
!
        isign = 1
        x1 = x
        if( x .gt. pi ) then
          isign = -isign
          x1 = twopi - x
        endif
        y1 = y
        if( y .gt. pi ) then
          isign = -isign
          y1 = twopi - y
        endif

!
! Choose very simple temperature profile cases.
!
        select case (init_f)
          case (1)
             init_temp = isign*(x1*(pi-x1))*y1*(pi-y1)
          case (2)
             init_temp = isign*(x1*(pi-x1))*y1*(pi-y1)*y1
          case (3)
             init_temp = isign*(x1*(pi-x1))*y1*(pi-y1)*x1
          case (4)
             init_temp = isign*(x1*(pi-x1))*y1*(pi-y1)*x1*y1
          case (5)
             init_temp = isign*(x1*(pi-x1))*y1*(pi-y1)
          case (6)
             init_temp = isign*(x1*(pi-x1))**2 *y1*(pi-y1)
          case (7)
             init_temp = isign*(x1*(pi-x1))*(y1*(pi-y1))**2
          case default
             init_temp = isign*sin(x1)*sin(y1)
        end select
        return
        end function init_temp

!****************************************************************************!
!*                                                                          *!
!*   Module routine diff_coef                                               *!
!*                                                                          *!
!*   Purpose: Return the value of the thermal diffusion coefficient at      *!
!*            an arbitrary point                                            *!
!*                                                                          *!
!****************************************************************************!
        function diff_coef(x, y)
!     Arguments:
!       x: real*8 (in), x coordinate
!       y: real*8 (in), y coordinate
!     Function return:
!       diff_coef: real*8 (out), diffusion coefficient at (x,y)
!
         real(long), intent(in) :: x, y
         real(long) :: diff_coef

!
!   The problem has been scaled to go from 0 to pi in both the x
!   and y directions. To simplify the matrix element calculations,
!   we define the function to be even about pi.
!

!  Local variables.
        real(long) :: x1, y1

!==============================================================================!
!          Start of executable code.                                           !
        x1 = x
        if( x .gt. pi )  x1 = twopi - x
        y1 = y
        if( y .gt. pi ) y1 = twopi - y

!
! Choose very simple diffusion coefficient cases.
!
        select case (diff_f)
           case (1)
             diff_coef = .5d0 + (x1 + y1) / (2 * twopi)
           case (2)
             diff_coef = ((1.d0 + x1)*(pi - x1 + 1.d0)*(y1 + pi))/ 3*pi
           case (3)
             diff_coef = (y1 + pi) * pi/((pi + x1) * (2* pi - x1))
           case default
             diff_coef = 1.d0
           end select
        return
        end function diff_coef

      end module diffusion


! BUCKLING_CPANELBAY_BARDELL program
!
! The required inputs that should be given are described below
!
! Run control
! -----------
! NUM : integer
!   Number of returned eigenvalues
!
! M : integer
!   Number of terms along x
!
! N : integer
!   Number of terms along x
!
! Geometry
! --------
! a : float
!   The panel length (dimension along x)
! b : float
!   The panel circumferential width (dimension along y)
! r : float
!   The panel radius.
!
! Applied Loads
! -------------
! Nxx : float
!   Nxx stress
! Nyy : float
!   Nyy stress
! Nxy : float
!   Nxy stress
!
! Laminate Constitutive Varibles (matrix ABD)
! -------------------------------------------
! A11 : float
!   Membrane stiffness along x
! A12 : float
!   Membrane stiffness
! A16 : float
!   Shear-extension coupling
! A22 : float
!   Membrane stiffness along y
! A26 : float
!   Shear-extension coupling
! A66 : float
!   Membrane Shear stiffness
! B11 : float
!   Bending-extension coupling
! B12 : float
!   Bending-extension coupling
! B16 : float
!   Bending-extension coupling
! B22 : float
!   Bending-extension coupling
! B26 : float
!   Bending-extension coupling
! B66 : float
!   Bending-extension coupling
! D11 : float
!   Bending stiffness
! D12 : float
!   Bending stiffness
! D16 : float
!   Bending-twist stiffness
! D22 : float
!   Bending stiffness
! D26 : float
!   Bending-twist stiffness
! D66 : float
!   Twist (torsion) stiffness
!
! Boundary conditions
! -------------------
! u1tx : float
!   If 1. the edge at x=0 can translate along u
!   If 0. the edge at x=0 cannot translate along u
! u1rx : float
!   If 1. the end at x=0 can rotate
!   If 0. the end at x=0 cannot translate along u
! u2tx : float
!   If 1. the edge at x=a can translate along u
!   If 0. the edge at x=a cannot translate along u
! u2rx : float
!   If 1. the end at x=a can rotate
!   If 0. the end at x=a cannot translate along u
! u1ty : float
!   If 1. the edge at y=0 can translate along u
!   If 0. the edge at y=0 cannot translate along u
! u1ry : float
!   If 1. the end at y=0 can rotate
!   If 0. the end at y=0 cannot translate along u
! u2ty : float
!   If 1. the edge at y=b can translate along u
!   If 0. the edge at y=b cannot translate along u
! u2ry : float
!   If 1. the end at y=b can rotate
!   If 0. the end at y=b cannot translate along u
! v1tx : float
!   If 1. the edge at x=0 can translate along v
!   If 0. the edge at x=0 cannot translate along v
! v1rx : float
!   If 1. the end at x=0 can rotate
!   If 0. the end at x=0 cannot translate along v
! v2tx : float
!   If 1. the edge at x=a can translate along v
!   If 0. the edge at x=a cannot translate along v
! v2rx : float
!   If 1. the end at x=a can rotate
!   If 0. the end at x=a cannot translate along v
! v1ty : float
!   If 1. the edge at y=0 can translate along v
!   If 0. the edge at y=0 cannot translate along v
! v1ry : float
!   If 1. the end at y=0 can rotate
!   If 0. the end at y=0 cannot translate along v
! v2ty : float
!   If 1. the edge at y=b can translate along v
!   If 0. the edge at y=b cannot translate along v
! v2ry : float
!   If 1. the end at y=b can rotate
!   If 0. the end at y=b cannot translate along v
! w1tx : float
!   If 1. the edge at x=0 can translate along w
!   If 0. the edge at x=0 cannot translate along w
! w1rx : float
!   If 1. the end at x=0 can rotate
!   If 0. the end at x=0 cannot translate along w
! w2tx : float
!   If 1. the edge at x=a can translate along w
!   If 0. the edge at x=a cannot translate along w
! w2rx : float
!   If 1. the end at x=a can rotate
!   If 0. the end at x=a cannot translate along w
! w1ty : float
!   If 1. the edge at y=0 can translate along w
!   If 0. the edge at y=0 cannot translate along w
! w1ry : float
!   If 1. the end at y=0 can rotate
!   If 0. the end at y=0 cannot translate along w
! w2ty : float
!   If 1. the edge at y=b can translate along w
!   If 0. the edge at y=b cannot translate along w
! w2ry : float
!   If 1. the end at y=b can rotate
!   If 0. the end at y=b cannot translate along w

INCLUDE 'calc_matrices.f90'
INCLUDE '../bardell.f90'
INCLUDE '../bardell_12.f90'
INCLUDE '../bardell_functions.f90'

PROGRAM BUCKLING_CPANELBAY_BARDELL
    IMPLICIT NONE
    INTERFACE
        SUBROUTINE integral_ff(i, j, x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r, out)
            IMPLICIT NONE
            INTEGER, INTENT(IN) :: i, j
            REAL*8, INTENT(IN) :: x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r
            REAL*8, INTENT(OUT) :: out
        END SUBROUTINE
        SUBROUTINE integral_ffxi(i, j, x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r, out)
            IMPLICIT NONE
            INTEGER, INTENT(IN) :: i, j
            REAL*8, INTENT(IN) :: x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r
            REAL*8, INTENT(OUT) :: out
        END SUBROUTINE
        SUBROUTINE integral_ffxixi(i, j, x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r, out)
            IMPLICIT NONE
            INTEGER, INTENT(IN) :: i, j
            REAL*8, INTENT(IN) :: x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r
            REAL*8, INTENT(OUT) :: out
        END SUBROUTINE
        SUBROUTINE integral_fxifxi(i, j, x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r, out)
            IMPLICIT NONE
            INTEGER, INTENT(IN) :: i, j
            REAL*8, INTENT(IN) :: x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r
            REAL*8, INTENT(OUT) :: out
        END SUBROUTINE
        SUBROUTINE integral_fxifxixi(i, j, x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r, out)
            IMPLICIT NONE
            INTEGER, INTENT(IN) :: i, j
            REAL*8, INTENT(IN) :: x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r
            REAL*8, INTENT(OUT) :: out
        END SUBROUTINE
        SUBROUTINE integral_fxixifxixi(i, j, x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r, out)
            IMPLICIT NONE
            INTEGER, INTENT(IN) :: i, j
            REAL*8, INTENT(IN) :: x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r
            REAL*8, INTENT(OUT) :: out
        END SUBROUTINE
        SUBROUTINE integral_ff_12(xi1, xi2, i, j, x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r, out)
            IMPLICIT NONE
            INTEGER, INTENT(IN) :: i, j
            REAL*8, INTENT(IN) :: xi1, xi2, x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r
            REAL*8, INTENT(OUT) :: out
        END SUBROUTINE
        SUBROUTINE integral_ffxi_12(xi1, xi2, i, j, x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r, out)
            IMPLICIT NONE
            INTEGER, INTENT(IN) :: i, j
            REAL*8, INTENT(IN) :: xi1, xi2, x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r
            REAL*8, INTENT(OUT) :: out
        END SUBROUTINE
        SUBROUTINE integral_ffxixi_12(xi1, xi2, i, j, x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r, out)
            IMPLICIT NONE
            INTEGER, INTENT(IN) :: i, j
            REAL*8, INTENT(IN) :: xi1, xi2, x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r
            REAL*8, INTENT(OUT) :: out
        END SUBROUTINE
        SUBROUTINE integral_fxifxi_12(xi1, xi2, i, j, x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r, out)
            IMPLICIT NONE
            INTEGER, INTENT(IN) :: i, j
            REAL*8, INTENT(IN) :: xi1, xi2, x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r
            REAL*8, INTENT(OUT) :: out
        END SUBROUTINE
        SUBROUTINE integral_fxifxixi_12(xi1, xi2, i, j, x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r, out)
            IMPLICIT NONE
            INTEGER, INTENT(IN) :: i, j
            REAL*8, INTENT(IN) :: xi1, xi2, x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r
            REAL*8, INTENT(OUT) :: out
        END SUBROUTINE
        SUBROUTINE integral_fxixifxixi_12(xi1, xi2, i, j, x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r, out)
            IMPLICIT NONE
            INTEGER, INTENT(IN) :: i, j
            REAL*8, INTENT(IN) :: xi1, xi2, x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r
            REAL*8, INTENT(OUT) :: out
        END SUBROUTINE
        SUBROUTINE calc_f(i, xi, x1t, x1r, x2t, x2r, out)
            IMPLICIT NONE
            INTEGER, INTENT(IN) :: i
            REAL*8, INTENT(IN) :: xi, x1t, x1r, x2t, x2r
            REAL*8, INTENT(OUT) :: out
        END SUBROUTINE
        SUBROUTINE calc_fxi(i, xi, x1t, x1r, x2t, x2r, out)
            IMPLICIT NONE
            INTEGER, INTENT(IN) :: i
            REAL*8, INTENT(IN) :: xi, x1t, x1r, x2t, x2r
            REAL*8, INTENT(OUT) :: out
        END SUBROUTINE
        SUBROUTINE CALC_K0Y1Y2(M, N, K0, y1, y2, a, b, r, ABD, &
                           u1tx, u1rx, u2tx, u2rx, u1ty, u1ry, u2ty, u2ry, &
                           v1tx, v1rx, v2tx, v2rx, v1ty, v1ry, v2ty, v2ry, &
                           w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry)
            IMPLICIT NONE
            INTEGER, INTENT(IN) :: M, N
            REAL*8, INTENT(IN) :: y1, y2, a, b, r
            REAL*8, INTENT(IN) :: ABD(6, 6)
            REAL*8, INTENT(IN) :: u1tx, u1rx, u2tx, u2rx, u1ty, u1ry, u2ty, u2ry
            REAL*8, INTENT(IN) :: v1tx, v1rx, v2tx, v2rx, v1ty, v1ry, v2ty, v2ry
            REAL*8, INTENT(IN) :: w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry
            REAL*8, INTENT(OUT) :: K0(3*M*N, 3*M*N)
        END SUBROUTINE
        SUBROUTINE CALC_KG0Y1Y2(M, N, KG0, y1, y2, a, b, Nxx, Nyy, Nxy, w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry)
            IMPLICIT NONE
            INTEGER, INTENT(IN) :: M, N
            REAL*8, INTENT(IN) :: y1, y2, a, b, Nxx, Nyy, Nxy
            REAL*8, INTENT(IN) :: w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry
            REAL*8, INTENT(OUT) :: KG0(3*M*N, 3*M*N)
        END SUBROUTINE
        SUBROUTINE CALC_K0F(M, N, K0F, ys, a, b, bf, df, &
                            E1, F1, S1, Jxx, &
                            u1tx, u1rx, u2tx, u2rx, u1ty, u1ry, u2ty, u2ry, &
                            w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry)
            IMPLICIT NONE
            INTEGER, INTENT(IN) :: M, N
            REAL*8, INTENT(IN) :: ys, a, b, bf, df
            REAL*8, INTENT(IN) :: E1, F1, S1, Jxx
            REAL*8, INTENT(IN) :: u1tx, u1rx, u2tx, u2rx, u1ty, u1ry, u2ty, u2ry
            REAL*8, INTENT(IN) :: w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry
            REAL*8, INTENT(OUT) :: K0F(3*M*N, 3*M*N)
        END SUBROUTINE
        SUBROUTINE CALC_KG0F(M, N, KG0F, ys, Fx, a, b, bf, df, &
                            u1tx, u1rx, u2tx, u2rx, u1ty, u1ry, u2ty, u2ry, &
                            w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry)
            IMPLICIT NONE
            INTEGER, INTENT(IN) :: M, N
            REAL*8, INTENT(IN) :: ys, Fx, a, b, bf, df
            REAL*8, INTENT(IN) :: u1tx, u1rx, u2tx, u2rx, u1ty, u1ry, u2ty, u2ry
            REAL*8, INTENT(IN) :: w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry
            REAL*8, INTENT(OUT) :: KG0F(3*M*N, 3*M*N)
        END SUBROUTINE

    END INTERFACE

    ! inputs
    CHARACTER BALANC, JOBVL, JOBVR, SENSE
    INTEGER NT, nulls, NUM, M, N
    REAL*8 a, b, r
    REAL*8, ALLOCATABLE :: K0(:, :), KG0(:, :), K02(:, :), KG02(:, :)
    REAL*8, ALLOCATABLE :: ABDs(:, :, :)
    REAL*8, ALLOCATABLE :: y1s(:), y2s(:), Nxxs(:), Nyys(:), Nxys(:)
    REAL*8, ALLOCATABLE :: NxxsCTE(:), NyysCTE(:), NxysCTE(:)
    REAL*8, ALLOCATABLE :: Fxs(:), FxsCTE(:), E1s(:), F1s(:), S1s(:), Jxxs(:)
    REAL*8, ALLOCATABLE :: ys(:), bfs(:), dfs(:)
    REAL*8 u1tx, u1rx, u2tx, u2rx, u1ty, u1ry, u2ty, u2ry
    REAL*8 v1tx, v1rx, v2tx, v2rx, v1ty, v1ry, v2ty, v2ry
    REAL*8 w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry
    INTEGER LDA, LDB, LDZ

    ! workspace
    CHARACTER (LEN=100) :: line
    CHARACTER (LEN=400) :: input_file, output_file
    INTEGER stat, ipanel, istiff, i, j, id, jd, NPANELS, NSTIFF
    INTEGER LWORK
    INTEGER, ALLOCATABLE :: IWORK(:)
    REAL*8, ALLOCATABLE :: WORK(:)
    INTEGER, ALLOCATABLE :: TMP(:)

    ! outputs
    INTEGER Mout, INFO
    INTEGER, ALLOCATABLE :: IFAIL(:)
    REAL*8, ALLOCATABLE :: EIGVALS(:), EIGVECS(:, :)

    BALANC = 'N'
    JOBVL = 'N'
    JOBVR = 'N'
    SENSE = 'N'

    NUM = 10
    M = 15
    N = 15

    ! Default boundary conditions (simply supported)
    u1tx = 0.
    u1rx = 1.D0
    u2tx = 0.D0
    u2rx = 1.D0
    u1ty = 0.D0
    u1ry = 1.D0
    u2ty = 0.D0
    u2ry = 1.D0
    v1tx = 0.D0
    v1rx = 1.D0
    v2tx = 0.D0
    v2rx = 1.D0
    v1ty = 0.D0
    v1ry = 1.D0
    v2ty = 0.D0
    v2ry = 1.D0
    w1tx = 0.D0
    w1rx = 1.D0
    w2tx = 0.D0
    w2rx = 1.D0
    w1ty = 0.D0
    w1ry = 1.D0
    w2ty = 0.D0
    w2ry = 1.D0

    IF (COMMAND_ARGUMENT_COUNT() .NE. 2) THEN
        STOP "This program should be called as: 'buckling_cpanel_bardell input output'"
    ELSE
        CALL GET_COMMAND_ARGUMENT(1, VALUE=input_file, STATUS=stat)
        CALL GET_COMMAND_ARGUMENT(2, VALUE=output_file, STATUS=stat)
    END IF

    ipanel = 0
    istiff = 0
    OPEN(10, FILE=input_file)
    DO
        READ(10, *) line
        IF (TRIM(line) == "NUM") READ(10, *) NUM

        IF (TRIM(line) == "NPANELS") THEN
            READ(10, *) NPANELS
            ALLOCATE(ABDs(NPANELS, 6, 6))
            ALLOCATE(y1s(NPANELS))
            ALLOCATE(y2s(NPANELS))
            ALLOCATE(Nxxs(NPANELS))
            ALLOCATE(Nyys(NPANELS))
            ALLOCATE(Nxys(NPANELS))
            ALLOCATE(NxxsCTE(NPANELS))
            ALLOCATE(NyysCTE(NPANELS))
            ALLOCATE(NxysCTE(NPANELS))
        ENDIF

        IF (TRIM(line) == "NSTIFF") THEN
            READ(10, *) NSTIFF
            ALLOCATE(ys(NSTIFF))
            ALLOCATE(bfs(NSTIFF))
            ALLOCATE(dfs(NSTIFF))
            ALLOCATE(E1s(NSTIFF))
            ALLOCATE(F1s(NSTIFF))
            ALLOCATE(S1s(NSTIFF))
            ALLOCATE(Jxxs(NSTIFF))
            ALLOCATE(Fxs(NSTIFF))
            ALLOCATE(FxsCTE(NSTIFF))
        ENDIF

        IF (TRIM(line) == "M") READ(10, *) M
        IF (TRIM(line) == "N") READ(10, *) N
        IF (TRIM(line) == "a") READ(10, *) a
        IF (TRIM(line) == "b") READ(10, *) b
        IF (TRIM(line) == "r") READ(10, *) r

        IF (TRIM(line) == "Panel") THEN
            READ(10, *) ipanel
            ABDs(ipanel, 6, 6) = 0.D0
            y1s(ipanel) = 0.D0
            y2s(ipanel) = 0.D0
            Nxxs(ipanel) = 0.D0
            Nyys(ipanel) = 0.D0
            Nxys(ipanel) = 0.D0
            NxxsCTE(ipanel) = 0.D0
            NyysCTE(ipanel) = 0.D0
            NxysCTE(ipanel) = 0.D0
        ENDIF

        IF (TRIM(line) == "y1") READ(10, *) y1s(ipanel)
        IF (TRIM(line) == "y2") READ(10, *) y2s(ipanel)

        IF (TRIM(line) == "Nxx") READ(10, *) Nxxs(ipanel)
        IF (TRIM(line) == "Nyy") READ(10, *) Nyys(ipanel)
        IF (TRIM(line) == "Nxy") READ(10, *) Nxys(ipanel)

        IF (TRIM(line) == "NxxCTE") READ(10, *) NxxsCTE(ipanel)
        IF (TRIM(line) == "NyyCTE") READ(10, *) NyysCTE(ipanel)
        IF (TRIM(line) == "NxyCTE") READ(10, *) NxysCTE(ipanel)

        IF (TRIM(line) == "A11") READ(10, *) ABDs(ipanel, 1, 1)
        IF (TRIM(line) == "A12") READ(10, *) ABDs(ipanel, 1, 2)
        IF (TRIM(line) == "A16") READ(10, *) ABDs(ipanel, 1, 3)
        IF (TRIM(line) == "A22") READ(10, *) ABDs(ipanel, 2, 2)
        IF (TRIM(line) == "A26") READ(10, *) ABDs(ipanel, 2, 3)
        IF (TRIM(line) == "A66") READ(10, *) ABDs(ipanel, 3, 3)

        IF (TRIM(line) == "B11") READ(10, *) ABDs(ipanel, 1, 4)
        IF (TRIM(line) == "B12") READ(10, *) ABDs(ipanel, 1, 5)
        IF (TRIM(line) == "B16") READ(10, *) ABDs(ipanel, 1, 6)
        IF (TRIM(line) == "B22") READ(10, *) ABDs(ipanel, 2, 5)
        IF (TRIM(line) == "B26") READ(10, *) ABDs(ipanel, 2, 6)
        IF (TRIM(line) == "B66") READ(10, *) ABDs(ipanel, 3, 6)

        IF (TRIM(line) == "D11") READ(10, *) ABDs(ipanel, 4, 4)
        IF (TRIM(line) == "D12") READ(10, *) ABDs(ipanel, 4, 5)
        IF (TRIM(line) == "D16") READ(10, *) ABDs(ipanel, 4, 6)
        IF (TRIM(line) == "D22") READ(10, *) ABDs(ipanel, 5, 5)
        IF (TRIM(line) == "D26") READ(10, *) ABDs(ipanel, 5, 6)
        IF (TRIM(line) == "D66") READ(10, *) ABDs(ipanel, 6, 6)

        IF (TRIM(line) == "Stiffener") THEN
            READ(10, *) istiff
            ys(istiff) = 0.D0
            bfs(istiff) = 0.D0
            dfs(istiff) = 0.D0
            E1s(istiff) = 0.D0
            F1s(istiff) = 0.D0
            S1s(istiff) = 0.D0
            Jxxs(istiff) = 0.D0
            Fxs(istiff) = 0.D0
            FxsCTE(istiff) = 0.D0
        END IF

        IF (TRIM(LINE) == "ys") READ(10, *) ys(istiff)
        IF (TRIM(LINE) == "bf") READ(10, *) bfs(istiff)
        IF (TRIM(LINE) == "df") READ(10, *) dfs(istiff)
        IF (TRIM(LINE) == "E1") READ(10, *) E1s(istiff)
        IF (TRIM(LINE) == "F1") READ(10, *) F1s(istiff)
        IF (TRIM(LINE) == "S1") READ(10, *) S1s(istiff)
        IF (TRIM(LINE) == "Jxx") READ(10, *) Jxxs(istiff)
        IF (TRIM(LINE) == "Fx") READ(10, *) Fxs(istiff)

        IF (TRIM(line) == "u1tx") READ(10, *) u1tx
        IF (TRIM(line) == "u1rx") READ(10, *) u1rx
        IF (TRIM(line) == "u2tx") READ(10, *) u2tx
        IF (TRIM(line) == "u2rx") READ(10, *) u2rx
        IF (TRIM(line) == "u1ty") READ(10, *) u1ty
        IF (TRIM(line) == "u1ry") READ(10, *) u1ry
        IF (TRIM(line) == "u2ty") READ(10, *) u2ty
        IF (TRIM(line) == "u2ry") READ(10, *) u2ry

        IF (TRIM(line) == "v1tx") READ(10, *) v1tx
        IF (TRIM(line) == "v1rx") READ(10, *) v1rx
        IF (TRIM(line) == "v2tx") READ(10, *) v2tx
        IF (TRIM(line) == "v2rx") READ(10, *) v2rx
        IF (TRIM(line) == "v1ty") READ(10, *) v1ty
        IF (TRIM(line) == "v1ry") READ(10, *) v1ry
        IF (TRIM(line) == "v2ty") READ(10, *) v2ty
        IF (TRIM(line) == "v2ry") READ(10, *) v2ry

        IF (TRIM(line) == "w1tx") READ(10, *) w1tx
        IF (TRIM(line) == "w1rx") READ(10, *) w1rx
        IF (TRIM(line) == "w2tx") READ(10, *) w2tx
        IF (TRIM(line) == "w2rx") READ(10, *) w2rx
        IF (TRIM(line) == "w1ty") READ(10, *) w1ty
        IF (TRIM(line) == "w1ry") READ(10, *) w1ry
        IF (TRIM(line) == "w2ty") READ(10, *) w2ty
        IF (TRIM(line) == "w2ry") READ(10, *) w2ry

        IF (TRIM(line) == "END") EXIT
    END DO

    NT = 3*M*N

    ! allocating arrays
    ALLOCATE(K0(NT, NT))
    ALLOCATE(KG0(NT, NT))

    K0 = 0.D0
    KG0 = 0.D0

    WRITE(*, *) "Calculating matrices for each panel..."
    DO i=1, NPANELS
        WRITE(*, *) "    Calculating panel ", i
        ! constitutive stiffness matrix K0
        CALL CALC_K0Y1Y2(M, N, K0, y1s(i), y2s(i), a, b, r, ABDs(i, :, :), &
                         u1tx, u1rx, u2tx, u2rx, u1ty, u1ry, u2ty, u2ry, &
                         v1tx, v1rx, v2tx, v2rx, v1ty, v1ry, v2ty, v2ry, &
                         w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry)
        ! constante stress state that contributes to K0
        CALL CALC_KG0Y1Y2(M, N, K0, y1s(i), y2s(i), a, b, &
                          NxxsCTE(i), NyysCTE(i), NxysCTE(i), &
                          w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry)
        ! geometric stiffness matrix
        CALL CALC_KG0Y1Y2(M, N, KG0, y1s(i), y2s(i), a, b, &
                          Nxxs(i), Nyys(i), Nxys(i), &
                          w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry)
    END DO
    WRITE(*, *) "finished!"

    WRITE(*, *) "Calculating matrices for each stiffener..."
    DO i=1, NSTIFF
        WRITE(*, *) "    Calculating stiffener ", i
        ! constitutive stiffness matrix K0
        CALL CALC_K0F(M, N, K0, ys(i), a, b, bfs(i), dfs(i), &
                      E1s(i), F1s(i), S1s(i), Jxxs(i), &
                      u1tx, u1rx, u2tx, u2rx, u1ty, u1ry, u2ty, u2ry, &
                      w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry)
        ! constante stress state that contributes to K0
        CALL CALC_KG0F(M, N, K0, ys(i), FxsCTE(i), a, b, bfs(i), dfs(i),&
                       u1tx, u1rx, u2tx, u2rx, u1ty, u1ry, u2ty, u2ry, &
                       w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry)
        ! geometric stiffness matrix
        CALL CALC_KG0F(M, N, KG0, ys(i), Fxs(i), a, b, bfs(i), dfs(i),&
                       u1tx, u1rx, u2tx, u2rx, u1ty, u1ry, u2ty, u2ry, &
                       w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry)
    END DO
    WRITE(*, *) "finished!"

    ! removing null rows and columns
    ALLOCATE(TMP(NT))
    TMP = 0
    WHERE (ABS(SUM(K0, DIM=1)) <= 0.0000001) TMP = 1
    nulls = SUM(TMP)
    WRITE(*, *) "Number of removed cols:", nulls

    ALLOCATE(K02(NT-nulls, NT-nulls))
    ALLOCATE(KG02(NT-nulls, NT-nulls))

    jd = 0
    DO j=1, NT
        IF (TMP(j) == 1) THEN
            jd = jd+1
            CYCLE
        END IF
        id = 0
        DO i=1, NT
            IF (TMP(i) == 1) THEN
                id = id+1
                CYCLE
            END IF
            K02(i-id, j-jd) = K0(i, j)
            KG02(i-id, j-jd) = KG0(i, j)
        END DO
    END DO
    DEALLOCATE(TMP)

    ! allocating arrays
    ALLOCATE(IWORK((NT-nulls)**2))

    ! allocating output arrays
    ALLOCATE(EIGVALS(NT-nulls))
    ALLOCATE(EIGVECS(NT-nulls, NT-nulls))
    ALLOCATE(IFAIL(NT-nulls))

    LDA = NT-nulls
    LDB = NT-nulls
    LDZ = NT-nulls

    WRITE(*, *) "Eigenvalue analysis started..."

    ! signature of eigenvalue solver used:
    !
    ! CALL DSYGVX(ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, &
    !             VL, VU, IL, IU, ABSTOL, Mout, W, Z, LDZ, &
    !             WORK, LWORK, IWORK, IFAIL, INFO)

    EIGVALS = EIGVALS*0

    ! Workspace query
    LWORK = -1
    ALLOCATE(WORK(1))
    CALL DSYGVX(1, "N", "I", "U", (NT-nulls), KG02, LDB, K02, LDA, &
                -1.D10, 0, 1, NUM, 0., Mout, EIGVALS, EIGVECS, LDZ, &
                WORK, LWORK, IWORK, IFAIL, INFO)
    LWORK = WORK(1)
    DEALLOCATE(WORK)
    ! Eigensolver query
    ALLOCATE(WORK(LWORK))
    CALL DSYGVX(1, "N", "I", "U", (NT-nulls), KG02, LDB, K02, LDA, &
                -1.D10, 0, 1, NUM, 0., Mout, EIGVALS, EIGVECS, LDZ, &
                WORK, LWORK, IWORK, IFAIL, INFO)
    DEALLOCATE(WORK)

    WHERE(EIGVALS /= 0) EIGVALS = -1/EIGVALS

    WRITE(*, *) "Eigenvalue analysis completed!"

    ! Writing eigenvalues
    OPEN(11, FILE=output_file, ACTION="WRITE", STATUS="REPLACE")
    DO i=1, NUM
        WRITE(11, *) EIGVALS(i)
    END DO

    IF (INFO /= 0) THEN
        WRITE(*, *) 'EIGVALS', EIGVALS(1), EIGVALS(2)
        WRITE(*, *) 'Mout', Mout
        WRITE(*, *) 'INFO', NT-nulls, INFO
        !WRITE(*, *) 'IFAIL', IFAIL
        WRITE(*, *) 'MIN(K02), MAX(K02)', MINVAL(K02), MAXVAL(K02)
        WRITE(*, *) 'SUM(K02), SUM(KG02)', SUM(K02), SUM(KG02)
    END IF
    WRITE(*, *) 'EIGVALS', EIGVALS(1), EIGVALS(2)
    WRITE(*, *) 'Mout', Mout
    WRITE(*, *) 'INFO', NT-nulls, INFO
    WRITE(*, *) 'MIN(K02), MAX(K02)', MINVAL(K02), MAXVAL(K02)
    WRITE(*, *) 'SUM(K02), SUM(KG02)', SUM(K02), SUM(KG02)

    DEALLOCATE(K0)
    DEALLOCATE(KG0)
    DEALLOCATE(K02)
    DEALLOCATE(KG02)
    DEALLOCATE(IWORK)
    DEALLOCATE(EIGVALS)
    DEALLOCATE(EIGVECS)
    DEALLOCATE(IFAIL)

END PROGRAM BUCKLING_CPANELBAY_BARDELL


c Compute intercept times and critical distances for "refracted" rays

	subroutine tiddid (jl, nl, v, vsq, thk, tid, did)

	implicit none

	include "hypoDD.inc"

c	Parameters:
	integer	jl
	integer	nl
	real	v(MAXLAY)	! (1..nl)
	real	vsq(MAXLAY)	! (1..nl)
	real	thk(MAXLAY)	! (1..nl)
	real	tid(20)	! (1..20)
	real	did(20)	! (1..20)

c       Determines the travel time intercept and critical
c  distance for a seismic ray in a layered earth model
c  originating at the top of layer jl, refracting in
c  layer m, and terminating at the top of layer 1.
c
c  input:       jl - event layer
c               nl - number of layers
c             v(l) - velocity of layer l
c           vsq(l) - velocity squared
c           thk(l) - thickness of layer l
c  output:
c           tid(m) - travel time intercept for
c                      refraction in layer m
c           did(m) - critical distance

c	Local variables:
	real	did1, did2
	real	dimm
	integer	j1
	integer	l
	integer	m
	integer	m1
	real	sqt
	real	tid1, tid2
	real	tim

      j1=jl+1
      do 23174m=j1,nl
      tid(m)=0.
      did(m)=0.
      tid1=0.
      tid2=0.
      did1=0.
      did2=0.
      m1=m-1
      do 23176l=1,m1
      if(.not.(vsq(m).le.vsq(l)))goto 23178

c   if m is a low velocity layer, set tid and did to
c   very large values

      tid(m)=100000.
      did(m)=100000.
      goto 23179
23178 continue
      sqt=sqrt(vsq(m)-vsq(l))
      tim=thk(l)*sqt/(v(l)*v(m))
      dimm=thk(l)*v(l)/sqt
      if(.not.(l.lt.jl))goto 23180

c   sum for layers above event layer

      tid1=tid1+tim
      did1=did1+dimm
      goto 23181
23180 continue

c   sum for layers below and including the event layer

      tid2=tid2+tim
      did2=did2+dimm
23181 continue
23179 continue
23176 continue
      if(.not.(tid(m).ne.100000.))goto 23182

c   calculate tid and did if m is not a low velocity layer

      tid(m)=tid1+2*tid2
      did(m)=did1+2*did2
23182 continue
23174 continue
      return
c  ***** end of subroutine tiddid *****
      end


      SUBROUTINE ks2d1s(x1,y1,n1,quadvl,d1,prob)
      INTEGER n1
      REAL d1,prob,x1(n1),y1(n1)
      EXTERNAL quadvl
CU    USES pearsn,probks,quadct,quadvl
      INTEGER j
      REAL dum,dumm,fa,fb,fc,fd,ga,gb,gc,gd,r1,rr,sqen,probks
      d1=0.0
      do 11 j=1,n1
        call quadct(x1(j),y1(j),x1,y1,n1,fa,fb,fc,fd)
        call quadvl(x1(j),y1(j),ga,gb,gc,gd)
        d1=max(d1,abs(fa-ga),abs(fb-gb),abs(fc-gc),abs(fd-gd))
11    continue
      call pearsn(x1,y1,n1,r1,dum,dumm)
      sqen=sqrt(float(n1))
      rr=sqrt(1.0-r1**2)
      prob=probks(d1*sqen/(1.0+rr*(0.25-0.75/sqen)))
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/ks2d1s.for


!==============================================================================!
  subroutine User_Mod_End_Of_Time_Step(grid, n, time)
!------------------------------------------------------------------------------!
!   This function is called at the beginning of time step.                     !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use Grid_Mod
  use Flow_Mod
  use Const_Mod, only: PI
  use Comm_Mod,  only: Comm_Mod_Global_Max_Real, this_proc
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Grid_Type) :: grid
  integer         :: n     ! time step
  real            :: time  ! physical time
!----------------------------------[Locals]------------------------------------!
  integer :: c, e, dir
  real    :: lo, xo(4), yo(4), zo, ro, xc, yc, zc, vc, wc, sig_x, sig_yz,  &
             rmin, rmax, sg, lx, ly, lz, vmax
!==============================================================================!

  ! If not time for disturbing the velocity field, return
  if(mod(n-33, 1500) .ne. 0) return

  ! If too late to disturb, get out too
  if(n > 3000) return

  ! Print a message
  if(this_proc < 2) then
    print *, '# Superimposing random eddies on top of velocity field!'
  end if

  ! Minimum and maximum size of eddies
  rmin = 0.2
  rmax = 0.4

  ! Size of the computational domain
  lx = 2.0 * PI
  ly = PI
  lz = 2.0

  ! Browse through all eddies
  do e = 1, 80

    ! Random direction of the vortex
    call random_number(sg);
    if(sg < 0.5) then
      sg = -1.0
    else
      sg = +1.0
    end if

    ! Determine random position of a vortex
    call random_number(ro);     ro    = rmin + (rmax-rmin)*ro  ! rmin -> rmax
    call random_number(xo(1));  xo(1) = xo(1) * lx
    call random_number(yo(1));  yo(1) = yo(1) * ly
    call random_number(zo);     zo = ro + (lz - 2.0*ro) * zo

    ! Handle periodicity; that is: copy eddie in periodic directions
    xo(2:4) = xo(1)
    yo(2:4) = yo(1)
    if(xo(1) > lx/2.0) xo(3) = xo(1) - lx
    if(xo(1) < lx/2.0) xo(3) = xo(1) + lx
    if(yo(1) > ly/2.0) yo(2) = yo(1) - ly
    if(yo(1) < ly/2.0) yo(2) = yo(1) + ly
    xo(4) = xo(3)
    yo(4) = yo(2)

    ! Length of the eddy is three times
    lo = ro * 3.0

    sig_yz = ro / 2.0
    sig_x  = lo / 2.0

    ! Superimpose eddies on the velocity field
    do dir = 1, 4
      do c = 1, grid % n_cells
        xc = grid % xc(c)
        yc = grid % yc(c)
        zc = grid % zc(c)
        wc = sg * sin( (yc-yo(dir))/ro * PI )
        vc = sg * sin( (zc-zo)/ro * PI )

        vc = vc / (sig_yz*sqrt(PI+PI))*exp(-0.5*((yc-yo(dir))/sig_yz)**2)
        vc = vc / (sig_yz*sqrt(PI+PI))*exp(-0.5*((zc-zo)     /sig_yz)**2)

        wc = wc / (sig_yz*sqrt(PI+PI))*exp(-0.5*((yc-yo(dir))/sig_yz)**2)
        wc = wc / (sig_yz*sqrt(PI+PI))*exp(-0.5*((zc-zo)     /sig_yz)**2)

        vc = vc / (sig_x *sqrt(PI+PI))*exp(-0.5*((xc-xo(dir))/sig_x)**2)
        wc = wc / (sig_x *sqrt(PI+PI))*exp(-0.5*((xc-xo(dir))/sig_x)**2)

        v % n(c) = v % n(c) + vc
        w % n(c) = w % n(c) + wc
      end do
    end do
  end do

  vmax = 0
  do c = 1, grid % n_cells
    vmax = max(vmax, abs(v % n(c)))
    vmax = max(vmax, abs(w % n(c)))
  end do
  call Comm_Mod_Global_Max_Real(vmax)
  do c = 1, grid % n_cells
    v % n(c) = v % n(c) / vmax / 10.0
    w % n(c) = w % n(c) / vmax / 10.0
  end do

  end subroutine


!______________________________________________________________________________
          subroutine  norm_overlap(npz2,znorm)
!______________________________________________________________________________
!    determination of overlap with the Pfafiian method
!    with the formula by Bertsch and Robledo, PRL108, 042505 (2012).
!
!    1. construct the skew-symmetric matrix M (4n * 4n)
!      where 2n is the dimension of the matrix V and U.
!
!          (  V(a)^T U^(a) ,  V(a)^T V^{(b)*}     )
!      M = (   ------------   ------------------ )
!          (               ,  U^{(b)+} V{(b)^+}  )
!
!          (      M^(a) ,           M^(c)        )
!        = (   ------------   ------------------ )
!          (               ,        M^(b)        )
!
!    2. calculate the Pfaffian of M
!
!    3. calculate the overlap <qa|qb> = (-1)^n * Pf(M)/ (N^(a)*N^(b))
!       where normalization factor N^(a) = Prod_i v^(a)_i.
!
!     calculate M matrice in norm overlap: <q_a|R|q_b>
!                                 NOTICE : <q_1|R|q_2>
!    4. return the norm overlap with phase
!----------------------------------------------------------------

!----------------------------------------------------------------
      use vaphfb_par
      implicit none
      integer npz2,npz4
      complex*16 znorm
!      parameter (ntest=10)
      character*1 UPLO, MTHD
      complex*16 Ma(npz2,npz2),Mb(npz2,npz2),Mc(npz2,npz2)
      complex*16 cva,cvb,pcva,pcvb
      complex*16 Zmax(npz4,npz4)
      complex*16 ipiv(npz4,npz4)
      complex*16 ztmp

!      complex*16 AV(npz4,npz4),EL(npz4),WORK(npz4*3)

!      dimension IWORK(npz4),RWORK(npz4)
!      complex*16 WORK2(npz4)
!       dimension IWORK_t(ntest),RWORK_t(ntest)
!       complex*16 aa(ntest,ntest),WORK2_t(ntest),
!     &            iaa(ntest,ntest)

      data UPLO/'U'/,MTHD/'P'/
!     ............................................................. initialization
       npz4 = npz2*2
       do i=1,npz4
       do j=1,npz4
           Zmax(j,i) = zero
       enddo ! j
       enddo ! i
!     ..............................................................
!     cna: prod_k u^a_k;  cnb: prod_l u^b_l
!     ..............................................................
        call zmaxa(npz2,Ma(1,1),cva)
        call zmaxb(npz2,Mb(1,1),cvb)
        call zmaxab(npz2,Mc(1,1))
!     .......................... construction of matrix M
       do i=1,npz2
          ir = i + npz2
       do j=1,npz2
          jr = j + npz2
          Zmax(i,j)    =  Ma(i,j)
          Zmax(i,jr)   =  Mc(i,j)
          Zmax(jr,i)   = -Mc(i,j)
          Zmax(ir,jr)  =  Mb(i,j)
       enddo ! j
       enddo ! i
!------------------------------------------------------
!     to calculate the Pfaffian of a skew-symmetric matrix
!------------------------------------------------------
!       TWO SUBROUTINES for Pfaffian of a complex matrix
!    The second one is (10 times) faster than the first one
!------------------------------------------------------

        call ZPfaffianF(Zmax(1,1),npz4,npz4,ipiv(1,1),ztmp)
!------------------------------------------------------
!        call ZSKPFA(UPLO,MTHD,npz4,Zmax,npz4,ztmp,
!     $              IWORK,WORK2,npz4, RWORK, INFO)
!------------------------------------------------------
!      write(*,*) 'cnorm=',cna*cnb,'ztmp1=',ztmp
!------------------------------------------------------
       on = iv(npz2/2)*ztmp/(cva*cvb)
!------------------------------------------------------

!      write(*,*) 'it=',it,'cnorm=',cna*cnb,'ztmp=',ztmp
     write(*,*) '<R> by Pf=',on
!----END NORM
      return
      END
!-------------------------------------------------------------------------------
      subroutine zmaxab(npz2,Mc)
!........................................................................
!     construct M^(c)
!     in a canoical basis
!........................................................................
      implicit real*8 (a-h,o-z)
      complex*16 Rmatrix,rot,rotive,Rive,on
      complex*16 zphi_n,zphi_p,zei2phi_n,zei2phi_p
      complex*16 zmatr,zmatrT
      complex*16 zmatr,Mc,Rmat(npz2,npz2),eiphi
      dimension zmatr(npz2,npz2),Mc(npz2,npz2),zmatr(npz2,npz2),zmatrT(npz2,npz2)
!    ....................................................................
      zphi_n    = cmplx(0,PNP%phi(1))
      zeiphi_n  = cdexp(zphi_n)
      zei2phi_n = cdexp(2*zphi_n)
      zphi_p    = cmplx(0,PNP%phi(2))
      zeiphi_p  = cdexp(zphi_p)
      zei2phi_p = cdexp(2*zphi_p)

          do i=1,npz2
          do j=1,npz2
             zmatr(i,j) = zero
             zmatrT(i,j) = zero
          enddo ! j
          enddo ! i
!     ...........................
          do k = 1, npz2
!     ................................................... partially occupied state
             if(HFB%vv1(k).le.PNP%eps1) goto 2
                vk = dsqrt(HFB%vv1(k))
                uk = dsqrt(1.d0-HFB%vv1(k))
                ik  = HFB%kocc1(k)

!                ikr = ik+npz
!                ik2 = 2*ik
!     ..........................................matrix elements of V^{(a)T}
!     (representation in s.p.states)
                cmatrT(ik2-1,ik2)   = -vk
                cmatrT(ik2,ik2-1)   =  vk
  2       enddo !k
          k1 = ka2(ib,it) + 1
          k2 = ka2(ib,it) + kd2(ib,it)
          do k = k1,k2
!     ................................................... partially
!     occupied state
             if(HFB%vv2(k).le.HFB%eps2) goto 3
                vk = dsqrt(HFB%vv2(k))
                uk = dsqrt(1.d0-HFB%vv2(k))
                ik  = HFB%kocc2(k)
                ikr = ik+npz(ib,it)
                ik2 = 2*ik
!     ..........................................matrix elements of V^{(b)}
!     (representation in s.p.states)
                cmatr(ik2-1,ik2)  =  eiphi*vk
                cmatr(ik2,ik2-1)  =  -eiphi*vk
  3       enddo !k

         npz1 = npz(ib,it)
!           write(97,*) '----- R----'
         do i = 1,npz1
            ir= i + npz1
            i2= i*2
         do j = 1,npz1
            jr= j + npz1
            j2= j*2
            Rmat(i2-1,j2-1) = Rmatrix(i,j,ib,it)
            Rmat(i2-1,j2  ) = Rmatrix(i,jr,ib,it)
            Rmat(i2  ,j2-1) = Rmatrix(ir,j,ib,it)
            Rmat(i2  ,j2  ) = Rmatrix(ir,jr,ib,it)
         enddo !i
!           write(97,10) (abs(Rmat(i,j)),j=1,npz2)
         enddo !i
!           write(97,*) '----- Mc----'
!     ........................................................
                do j=1,npz2
                do k=1,npz2
                   zmatr(j,k) = zero
                do l=1,npz2
                   zmatr(j,k) = zmatr(j,k)    + Rmat(j,l) * cmatr(l,k)
                enddo ! l
                enddo ! k
                enddo ! j
                do i=1,npz2
                do j=1,npz2
                   Mc(i,j) = zero
                do l=1,npz2
                   Mc(i,j) = Mc(i,j)  + cmatrT(i,l)*zmatr(l,j)
                enddo ! l
                enddo ! j
!                  write(97,10) (abs(Mc(i,j)),j=1,npz2)
                enddo ! i
  10    format(40f20.18)
!     ........................................................
      return
      end

!........................................................................
      subroutine zmaxa(npz2,Ma,cna)
!........................................................................
!     construct the M^(a)
!     in a canoical basis
!     1 <-> a
!     2 <-> b
!     <a | b>
!----------------------------------------------------------------
      implicit real*8 (a-h,o-z)
      complex*16 Ma,cmatr
      dimension Ma(npz2,npz2),cmatr(npz2,npz2)

!    ....................................................................
         do i=1,npz2
            do j=1,npz2
                cmatr(i,j)=zero
            enddo ! j
          enddo ! i
          cna = one
!     ...........................
          k1 = ka1(ib,it) + 1
          k2 = ka1(ib,it) + kd1(ib,it)
          do k = k1,k2
!     ................................................... partially
!     occupied state
             if(HFB%vv1(k).le.PNP%eps1) goto 3   ! -> q2
                vk  = dsqrt(HFB%vv1(k))
                uk  = dsqrt(1.d0-HFB%vv1(k))
                ik  = HFB%kocc1(k)
                ikr = ik+npz(k,it)
!     ..........................................matrix elements of f
!     (representation in s.p.states)
                ik2 = ik*2
                cmatr(ik2-1,ik2)  = -vk*uk
                cmatr(ik2,ik2-1)  =  vk*uk
                cna  =  cna * vk
  3       enddo !k
!     ........................................................
       do i=1,npz2
       do j=1,npz2
           Ma(j,i) = cmatr(j,i)
       enddo ! j
       enddo ! i

      return
      end
c==============================================================================
!........................................................................
      subroutine zmaxb(npz2,Mb,cnb)
!........................................................................
!     construct the M^(b)
!     in a canoical basis
!     1 <-> a
!     2 <-> b
!     <a | b>
!----------------------------------------------------------------
      implicit real*8 (a-h,o-z)
      complex*16 Mb,cmatr
      dimension Mb(npz2,npz2),cmatr(npz2,npz2)

!    ....................................................................
         do i=1,npz2
            do j=1,npz2
                cmatr(i,j)=zero
            enddo ! j
          enddo ! i
          cnb = one
!     ...........................

          k1 = ka2(ib,it) + 1
          k2 = ka2(ib,it) + kd2(ib,it)
          do k = k1,k2
!     ................................................... partially
!     occupied state
             if(vocc2(k,it).le.epsocc2(ib,it)) goto 3   ! -> q2
                vk  = dsqrt(vv2(k,it))
                uk  = dsqrt(1.d0-vv2(k,it))
                ik  = HFB%kocc2(k,it)
                ikr = ik+npz(ib,it)
!     ..........................................matrix elements of f
!     (representation in s.p.states)
                ik2 = ik*2
                cmatr(ik2-1,ik2)  =  vk*uk
                cmatr(ik2,ik2-1)  = -vk*uk
                cnb  =  cnb * vk
  3       enddo !k
!     ........................................................
       do i=1,npz2
       do j=1,npz2
           Mb(j,i) = cmatr(j,i)
       enddo ! j
       enddo ! i

      return
      end


*
*------------------------------------------------------------------------
*        L T R I A N G
*------------------------------------------------------------------------
*
	LOGICAL FUNCTION ltriang(k,li,lj)
	INTEGER k,li,lj
*
*       Return a value of TRUE if k,li,lj form a triangle
*
	IF ( mod(k+li+lj,2) .ne. 0) then
	   ltriang = .false.
	else
	  IF (abs(li-lj) .gt. k ) then
	    ltriang = .false.
	  else if (li+lj .lt. k) then
	    ltriang = .false.
	  else
	    ltriang = .true.
	  end if
	end if
	end


module m_rorder
   implicit none

CONTAINS
   ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
   !     Orders iarr(1:n) according to size and returns a correspondingly defined pointer in pnt
   SUBROUTINE iorderp(pnt, iarr, n)

      IMPLICIT NONE

      INTEGER, INTENT(IN)  :: n
      INTEGER, INTENT(OUT) :: pnt(1:n)
      INTEGER, INTENT(IN)  :: iarr(1:n)
      INTEGER                :: i, j, k

      DO i = 1, n
         pnt(i) = i
         DO j = 1, i - 1
            IF (iarr(pnt(j)) > iarr(i)) THEN
               DO k = i, j + 1, -1
                  pnt(k) = pnt(k - 1)
               END DO
               pnt(j) = i
               EXIT
            END IF
         END DO
      END DO

   END SUBROUTINE iorderp

! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!     Orders rarr(1:n) according to size and returns a correspondingly defined pointer in pnt

   SUBROUTINE rorderp(pnt, rarr, n)

      IMPLICIT NONE

      INTEGER, INTENT(IN)  :: n
      INTEGER, INTENT(OUT) :: pnt(1:n)
      REAL, INTENT(IN)  :: rarr(1:n)
      INTEGER                :: i, j, k

      DO i = 1, n
         pnt(i) = i
         DO j = 1, i - 1
            IF (rarr(pnt(j)) > rarr(i)) THEN
               DO k = i, j + 1, -1
                  pnt(k) = pnt(k - 1)
               END DO
               pnt(j) = i
               EXIT
            END IF
         END DO
      END DO

   END SUBROUTINE rorderp

!     Same as rorderp but divides the problem in halves np times (leading to 2**np intervals) and is
!     much faster than rorderp (devide and conquer algorithm).
!     There is an optimal np, while for larger np the overhead (also memory-wise) outweights the speed-up.
!     np = max(0,int(log(n*0.001)/log(2.0))) should be a safe choice.
   RECURSIVE SUBROUTINE rorderpf(pnt, rarr, n, np)
      use m_judft
      IMPLICIT NONE

      INTEGER, INTENT(IN)  :: n, np
      INTEGER, INTENT(OUT) :: pnt(n)
      REAL  , INTENT(IN)  :: rarr(n)
      REAL                   :: rarr1(n)
      REAL                   :: ravg
      INTEGER                :: pnt1(n), pnt2(n)
      INTEGER                :: n1, n2, i

      IF (np == 0) THEN
         CALL rorderp(pnt, rarr, n)
         RETURN
      ELSE IF (np < 0) THEN
         call judft_error("rorderpf: fourth argument must be non-negative (bug?).")
      END IF
      ravg = sum(rarr)/n
! first half
      n1 = 0
      DO i = 1, n
         IF (rarr(i) <= ravg) THEN
            n1 = n1 + 1
            rarr1(n1) = rarr(i)
            pnt1(n1) = i
         END IF
      END DO
      CALL rorderpf(pnt2, rarr1, n1, np - 1)
      pnt(:n1) = pnt1(pnt2(:n1))
! second half
      n2 = 0
      DO i = 1, n
         IF (rarr(i) > ravg) THEN
            n2 = n2 + 1
            rarr1(n2) = rarr(i)
            pnt1(n2) = i
         END IF
      END DO
      CALL rorderpf(pnt2, rarr1, n2, np - 1)
      pnt(n1 + 1:) = pnt1(pnt2(:n2))
   END SUBROUTINE rorderpf

end module m_rorder


program testForward
    use substitution
    use, intrinsic:: iso_fortran_env
    implicit none
    integer:: j, ierr
    namelist/matrixdataL/ L, b

    real(DP):: L(3,3), b(3)
    ierr=0
    read(INPUT_UNIT,matrixdataL)
    call forward_subs(L, 3, b, ierr)
    if(ierr.eq.0) then
       write(OUTPUT_UNIT,*) b
    else
       write(OUTPUT_UNIT,*) 'error: ', ierr
    endif  ! or END IF
    stop
end program testForward


program main
    use plantfem
    implicit none

    integer,parameter::n=100
    real(8) :: a(n),b(n)
    real(8) :: dp,t0,t1,t2,t3

    a(:)=100.0d0
    b(:)=1.0d0

    call cpu_time(t0)
    dp=c_dot_product(a,b,n)
    print *,dp
    call cpu_time(t1)
    dp=dot_product(a,b)
    print *,dp
    call cpu_time(t2)

    print *, "ref.   : ",t2-t1,"sec."
    print *, "OpenCL : ",t1-t0,"sec."

end program


! Learn_dg - A quick and dirty project to deploy a working DG solver
! Copyright (c) 2017, Chris Coutinho
! All rights reserved.
!
! Licensed under the BSD-2 clause license. See LICENSE for details.

submodule (mod_legendre) smod_legendre_1D
  !*
  ! Legendre_1D is a submodule used to generate arrays of coeffiecents used for
  ! developing finite element basis functions in 1D. Finite element basis
  ! functions are defined at internal nodes and used to iterpolate some value
  ! between those nodes.
  !
  !
  ! calculate the coeffiecents associated with a univarate Lagrangian polynomial
  !
  ! \[ 1, x, x^2, ..., x^N \]
  !
  !
  ! In the end you end up with a group of basis functions similar to this:
  !
  ! ![Quadratic Basis Functions catption](|media|/quadratic_basis.png "Quadratic Basis Functions"){: width="500" }
  ! {: style="text-align: center" }

  use :: mod_linalg, only: linsolve_quick, eye
  use :: lib_array, only: linspace
  implicit none

contains

  pure module function getArow1D(N, xi) result(row)
    integer, intent(in)     :: N
    real(wp), intent(in)    :: xi
    real(wp), dimension(N)  :: row

    row = pascal_row(N-1, xi)

    return
  end function getArow1D

  module function getx(N) result(x)
    integer,  intent(in)      :: N
    real(wp), dimension(N)    :: x

    call linspace(-1.d0, 1.d0, x)

    ! Gmsh orders all their lines as endpoint1, endpoint2, internal...
    ! Therefore, need to reorder if numpts is more than 2
    if ( N>2 ) x = [x(1), x(N), x(2:N-1)]

    return
  end function getx

  module function getAlpha1D(N) result(alpha)
    integer, intent(in)       :: N
    real(wp), dimension(N,N)  :: alpha

    real(wp), dimension(N,N)  :: A, B

    A = getA(N)
    B = eye(N)

    call linsolve_quick(N, A, N, B, alpha)

    return
  contains
    function getA(N) result(A)
      integer, intent(in)       :: N
      real(wp), dimension(N,N)  :: A

      integer                   :: ii
      real(wp), dimension(N)    :: x

      x = getx(N)

      do ii = 1,N
        A(ii,:) = getArow1D(N, x(ii))
      enddo

      return
    end function getA
  end function getAlpha1D

  ! module procedure pascal_1D_line
  pure module function pascal_1D_line(N, x) result(row)
    !*
    ! Generates the elements of an array associated with a univarate
    ! Lagrange polynomial.

    integer,  intent(in)      :: N
    real(wp), intent(in)      :: x
    real(wp), dimension(N+1)  :: row

    integer :: ii

    row = [( x**(ii-1), ii = 1, N+1 )]

    return
  end function pascal_1D_line
  ! end procedure pascal_1D_line

  pure module function basis_1D(x, alpha, dx) result(y)
    ! Input/output variables
    integer,  intent(in)                            :: dx
    real(wp), intent(in), dimension(:)              :: x
    real(wp), intent(in), dimension(:)              :: alpha
    real(wp),             dimension(:), allocatable :: y, yx

    ! Local variables
    integer :: ii, N

    allocate(y, mold=x)
    allocate(yx, mold=x)

    N = size(alpha)
    y = 0._wp

    do ii = 1+dx, N

      yx = dble((ii-1)**dx) * alpha(ii) * x ** dble(ii-1-dx)

      y = y + yx

    enddo

    return
  end function basis_1D

end submodule smod_legendre_1D