*----------------------------------------------------------------------*
      subroutine set_spprjmap_cases(iocc,idspn_prm)
*----------------------------------------------------------------------*
*     loops over all possible permutations of a simple spin string
*     and assignes a number to each.
*     the reference permutation (with alternating + and -) is el. #0.
*     the permutation numbers are written to idspn_prm(0,0:2**iocc-1),
*     and the spin strings are written to idspn_prm(1:iocc,0:2**iocc-1)
*
*     matthias, feb 2014
*----------------------------------------------------------------------*
      implicit none

      integer, intent(in) ::
     &     iocc
      integer, intent(out) ::
     &     idspn_prm(0:iocc,0:2**iocc-1)

      integer
     &     icnt, icase, idigit

      icase = 0
      do icnt = 0, 2**iocc-1
        ! check if this is the reference element:
        ! +, -+, +-+, -+-+, ...
        ! the reference element has a + (0 bit) on the right
        ! and alternating + and - (0 and 1 bits)
        if (.not.btest(icnt,0).and.
     &      ieor(icnt,ishftc(icnt,-1,iocc)).eq.2**((iocc/2)*2)-1) then
          idspn_prm(0,0) = icnt
          do idigit = 1, iocc
            idspn_prm(idigit,0) = -2*ibits(icnt,iocc-idigit,1)+1
          end do
          cycle
        end if
        icase = icase+1
        do idigit = 1, iocc
          idspn_prm(idigit,icase) = -2*ibits(icnt,iocc-idigit,1)+1
        end do
        idspn_prm(0,icase) = icnt
      end do

      return
      end


CHARACTER(10) :: intstr = "12345", realstr = "1234.5"
INTEGER :: i
REAL :: r

READ(intstr, "(I10)") i        ! Read numeric string into integer i
i = i + 1                      ! increment i
WRITE(intstr, "(I10)") i       ! Write i back to string

READ(realstr, "(F10.1)") r
r = r + 1.0
WRITE(realstr, "(F10.1)") r


module mymodule
    type pocketdimension
        integer,dimension(-100:100, -100:100, -100:100) :: values
    end type

    contains
end module

program main
    use mymodule
    implicit none

    type(pocketdimension) :: pd
    integer :: n

    call load(pd)

    do n=1,6
        call iterate(pd)
    end do

    call num_active_cubes(pd, n)
    print *, "Num. active after boot:", n
    ! call show(pd)
end

subroutine num_active_neighbours(pd, x, y, z, n)
    use mymodule
    implicit none
    type(pocketdimension), intent(in) :: pd
    integer, intent(in) :: x, y, z
    integer, intent(out) :: n

    integer :: i, j, k

    n = 0
    do k = -1,1
        do j = -1,1
            do i = -1,1
                if (k == 0 .and. j == 0 .and. i == 0) then
                    ! Skip the current cell
                else if (pd%values(x+i, y+j, z+k) == 1) then
                    n = n + 1
                end if
            end do
        end do
    end do
    return
end

subroutine num_active_cubes(pd, n)
    use mymodule
    implicit none
    type(pocketdimension), intent(in) :: pd
    integer, intent(out) :: n

    n = sum(pd%values)
end

subroutine iterate(pd)
    use mymodule
    implicit none
    type(pocketdimension), intent(inout) :: pd
    type(pocketdimension) :: tmp

    integer :: x, y, z
    integer :: n
    integer :: here

    tmp = pd

    do z = lbound(pd%values,3)+1, ubound(pd%values,3)-1
        do y = lbound(pd%values,2)+1, ubound(pd%values,2)-1
            do x = lbound(pd%values,1)+1, ubound(pd%values,1)-1

                here = pd%values(x, y, z)
                call num_active_neighbours(pd, x, y, z, n)

                if (here == 1) then
                    if (n == 2 .or. n == 3) then
                        ! Remain active
                    else
                        tmp%values(x, y, z) = 0
                    end if

                else if (here == 0) then
                    if (n == 3) then
                        tmp%values(x, y, z) = 1
                    else
                        ! Remain inactive
                    end if
                end if
            end do
        end do
    end do

    pd = tmp
end

subroutine show(pd)
    use mymodule
    implicit none
    type(pocketdimension), intent(in) :: pd
    integer :: x, y, z
    integer :: here

    do z = lbound(pd%values,3), ubound(pd%values,3)
        print *, "z = ", z
        do y = lbound(pd%values,2), ubound(pd%values,2)
            do x = lbound(pd%values,1), ubound(pd%values,1)
                here = pd%values(x, y, z)
                if (here == 1) then
                    write (*, "(A)", advance="no") "#"
                else if  (here == 2) then
                    write (*, "(A)", advance="no") "O"
                else
                    write (*, "(A)", advance="no") "."
                end if
                ! write (*, "(I1)", advance="no") pd%values(x, y, z)
                ! print *,
            end do
            print *, ""
        end do
    end do
end

subroutine load(output)
    use mymodule
    implicit none

    ! character(len = *), parameter :: filename = "../test_input1.txt"
    ! integer, parameter :: num_rows = 3, num_cols = 3

    character(len = *), parameter :: filename = "../puzzle_input.txt"
    integer, parameter :: num_rows = 8, num_cols = 8

    type(pocketdimension), intent(out) :: output
    integer ::  x, y, z, row, col
    character :: c
    character(len = 80) :: line

    output%values = 0

    open(1, file = filename, status = "old")

    z = 0

    do row = 1,num_rows
        read (1,*) line
        do col = 1,num_cols
            c = line(col:col)

            x = col - 1
            y = row - 1
            z = 0

            if (c .eq. "#") then
                output%values(x, y, z) = 1
            else if (c .eq. ".") then
                output%values(x, y, z) = 0
            end if

        end do
    end do

    close(1)

    return
end


MODULE blurmod
  IMPLICIT NONE
  CONTAINS

  SUBROUTINE blur(image, its)

    INTEGER, DIMENSION(0:,0:), INTENT(INOUT) :: image
    INTEGER, INTENT(IN) :: its
    INTEGER :: ix, iy, iit, UB1, UB2
    INTEGER, DIMENSION(:,:), ALLOCATABLE :: temp

    ALLOCATE(temp, SOURCE = image)

    UB1 = UBOUND(image,2) - 1
    UB2 = UBOUND(image,1) - 1

    DO iit = 1, its
!$OMP PARALLEL
!$OMP DO
      DO iy = 1, UB1
        DO ix = 1, UB2
          temp(ix,iy) = INT(0.25 * REAL(image(ix+1,iy) + image(ix-1,iy) &
              + image(ix,iy+1) + image(ix,iy-1)))
        END DO
      END DO
!$OMP END DO
!$OMP WORKSHARE
      image = temp
!$OMP END WORKSHARE
!$OMP END PARALLEL
    END DO

  END SUBROUTINE blur
END MODULE blurmod

PROGRAM omptest

  USE blurmod
  USE omp_lib
  IMPLICIT NONE
  INTEGER, DIMENSION(0:1001, 0:1001) ::image
  INTEGER :: t1, t2
  REAL :: tick

  image = 5
  PRINT '(A,I0,A)','OpenMP code running on ', omp_get_max_threads(), ' threads'
  CALL SYSTEM_CLOCK(COUNT_RATE = tick)
  CALL SYSTEM_CLOCK(COUNT=t1)
  CALL blur(image, 10000)
  CALL SYSTEM_CLOCK(COUNT=t2)
  PRINT '(A,F5.2,A)','Time taken was ',REAL(t2-t1)/tick, ' seconds'
  PRINT '(A,I0)', 'Maximum of image was ', MAXVAL(image)
  PRINT '(A)', 'Maximim value printed to avoid compiler optimising the blur out'

END PROGRAM omptest


program lsqTest

implicit none

integer, parameter :: m = 20, n = 10
real(8) :: a(m,n), b(m), x(n)
integer :: i, j

character(len=56) :: formatstring

do j = 1, n
	do i = 1, m
		!a(i,j) = real( (i+j)/real(i*j,8) + i, 8)
		call random_number(a(i,j))
	enddo
enddo

do i = 1, m
	b(i) = 1.0d0
enddo

write(6,'(A)',advance='NO') "A = ["
do i = 1, m-1
	do j = 1, n-1
		write(6,'(F18.6,2X,A)',advance='NO') a(i,j), ", "
	enddo
	write(6,'(F18.6,2X,A)') a(i,n), "; ..."
enddo
do j = 1, n-1
	write(6,'(F18.6,2X,A)',advance='NO') a(m,j), ", "
enddo
write(6,'(F18.6,2X,A)') a(m,n), "];"

call wrapped_dgelsy( m, n, A, b, x )

write(6,'(A)', advance = 'NO') "coefficients = "
write(6,'(4(E18.6,2X))') x(1), x(2), x(3), x(4)
write(6,'(3(E18.6,2X))') x(5), x(6), x(7)
write(6,'(2(E18.6,2X))') x(8), x(9)
write(6,'(E18.6)') x(10)

contains

subroutine wrapped_dgelsy( m, n, A, b, x )
	integer, intent(in) :: m
	integer, intent(in) :: n
	real(8), intent(inout) :: A(m,n)
	real(8), intent(inout) :: b(m)
	real(8), intent(out) :: x(n)
	!
	integer :: nRhs, lda, ldb, jpvt(n), rank, lwork, info
	real(8) :: rcond
	real(8) :: work(4*n+1)

	nrhs = 1
	lda = m
	ldb = m
	lwork = 4*n+1
	jpvt = 0

	call DGELSY( m, n, nrhs, A, lda, b, ldb, jpvt, rcond, rank, work, lwork, info )

	if ( info == 0 ) then
		print *, "SUCCESS."
	elseif ( info < 0 ) then
		print *, "illegal value in argument ", -i
	else
		print *, "undefined error"
	endif
	x = b(1:n)
end subroutine

end program


        function intmatmul(limit, width, height)

        integer, intent(in) :: limit
        integer, intent(in) :: width
        integer, intent(in) :: height

        integer :: max_width, max_height, max_input, max_output

        parameter (max_width = 1024, max_height = 1024)
        parameter (max_input = max_width * max_height)
        parameter (max_output = max_height * max_height)

        integer :: a(max_width * max_height)
        integer :: b(max_height * max_width)
        integer :: c(max_height * max_height)

        integer :: n, y, i, x

        integer :: intmatmul

        data a /max_input * 1/
        data b /max_input * 1/
        data c /max_output * 0/

        do n = 1, limit
            c = 0
            !$omp parallel do
            do y = 1, height
                do i = 1, width
                    do x = 1, height
                        c((y - 1) * height + x) =
     +                      c((y - 1) * height + x) +
     +                      a((y - 1) * width + i) *
     +                      b((i - 1) * height + x)
                    end do
                end do
            end do
            !$omp end parallel do
        end do

        if (limit .gt. 0) then
            do y = 1, height
                do x = 1, height
                    if (c((y - 1) * height + x) .ne. height) then
                        print '(I0, '' - error at '', I0, '' x '', I0)',
     +                      c((y - 1) * height + x), x, y
                        intmatmul = 2
                        return
                    end if
                end do
            end do
        end if

        intmatmul = 0

        end function intmatmul

        program main

        implicit none
        integer :: fileId
        integer :: limit, width, height

        integer :: intmatmul
        external intmatmul
        integer :: returncode

        parameter (fileId = 20)

        limit = 0
        width = 0
        height = 0

        open(fileId, file='res/input.txt', status='OLD')
        read(fileId, fmt='(I8,I8,I8)') limit, width, height
        close(fileId, status='KEEP')

        if (limit .lt. 0 .or. width .eq. 0 .or. height .eq. 0) then
            stop 1
        end if

C        print "(I0, ' times ', I0, ' x ', I0)", limit, width, height

        returncode = intmatmul(limit, width, height)

        if (returncode .ne. 0) then
            stop 2
        end if

        end program main


subroutine rpn2(ixy,maxm,meqn,mwaves,maux,mbc,mx,ql,qr,auxl,auxr,fwave,s,amdq,apdq)
! ============================================================================
!  Solves normal Riemann problem for the multilayer shallow water equations in
!  2D with topography:
!    (rho_1 h_1)_t + (rho_1 h_1 u_1)_x + (rho_1 h_1 v_1)_y = 0
!    (rho_1 h_1 u_1)_t + (rho_1 h_1 u_1^2 + 1/2 g rho_1 h_1^2)_x + (rho_1 h_1 u_1 v_1)_y = -g rho_1 h_1(r(h_2)_x + B_x)
!    (rho_1 h_1 v_1)_t + (rho_1 h_1 u_1 v_1)_x + (rho_1 h_1 v_1^2 + 1/2 g rho_1 h_1^2)_y = -g rho_1 h_1(r(h_2)_y + B_y)
!    (rho_2 h_2)_t + (rho_2 h_2 u_2)_x + (rho_2 h_2 v_2)_y = 0
!    (rho_2 h_2 u_2)_t + (rho_2 h_2 u_2^2 + 1/2 g rho_2 h_2^2)_x + (rho_2 h_2 u_2 v_2)_y = -g rho_2 h_2(h_1 + B)_x
!    (rho_2 h_2 v_2)_t + (rho_2 h_2 u_2 v_2)_x + (rho_2 h_2 v_2^2 + 1/2 g rho_2 h_2^2)_y = -g rho_2 h_2(h_1 + B)_y
!
!  On input, ql contains the state vector at the left edge of each cell and qr
!  contains the state vector at the right edge of each cell
!
!           |            |
!    qr(i-1)|ql(i)  qr(i)|ql(i+1)
! ----------|------------|----------
!    i-1          i         i+1
!
!  The i-1/2 Riemann problem has left state qr(i-1) and right state ql(i)
!
!  If ixy == 1 then the sweep direction is x, ixy == 2 implies the y direction
!
!  Wet-Dry Interface Cases handled
!    Dry State Table    #  Handled?    Line #     Comment
!  L(1) L(2) R(1) R(2)
!   F    F    F    F    4  [X]        XXX        Full two-layer case
!
!   T    F    F    F    1  [ ]                   Dry state top layer
!   F    T    F    F    1  [X]        XXX        Lower left dry state
!   F    F    T    F    1  [ ]                   Dry state top layer
!   F    F    F    T    1  [X]        XXX        Lower right dry state
!
!   T    T    F    F    2  [X]        XXX        Left state completely dry
!   F    T    T    F    2  [ ]
!   F    F    T    T    2  [X]        240        Right state completely dry
!   T    F    F    T    2  [ ]
!
!   T    F    T    F    2  [X]        182        Single layer all-wet bottom
!   F    T    F    T    2  [X]        182        Single layer all-wet top
!
!   T    T    T    F    3  [X]        195        Single layer dry-state
!   F    T    T    T    3  [X]        195        Single layer dry-state
!   T    F    T    T    3  [X]        195        Single layer dry-state
!   T    T    F    T    3  [X]        195        Single layer dry-state
!
!   T    T    T    T    4  [X]        173        All dry
! ============================================================================

    use amr_module, only: mcapa

    use geoclaw_module, only: g => grav, pi, earth_radius

    use multilayer_module, only: num_layers, eigen_func
    use multilayer_module, only: dry_tolerance, aux_layer_index, rho, r
    use multilayer_module, only: eigen_method, inundation_method
    use multilayer_module, only: eigen_func, inundation_eigen_func

    implicit none

    ! Input arguments
    integer, intent(in) :: ixy,maxm,meqn,mwaves,mbc,mx,maux
    real(kind=8), dimension(meqn,1-mbc:maxm+mbc), intent(in) :: ql, qr
    real(kind=8), dimension(maux,1-mbc:maxm+mbc), intent(in) :: auxl, auxr

    ! Output arguments
    real(kind=8), dimension(meqn, mwaves, 1-mbc:maxm+mbc), intent(out) :: fwave
    real(kind=8), dimension(mwaves, 1-mbc:maxm+mbc), intent(out) :: s
    real(kind=8), dimension(meqn, 1-mbc:maxm+mbc), intent(out) :: apdq, amdq

    ! Counters
    integer :: i, j, mw, info
    integer :: n_index, t_index, layer_index

    ! Physics
    real(kind=8) :: dxdc

    ! State variables
    real(kind=8), dimension(num_layers) :: h_l, h_r, hu_l, hu_r, hv_l, hv_r
    real(kind=8), dimension(num_layers) :: u_l, u_r, v_l, v_r
    real(kind=8), dimension(num_layers) :: h_ave, momentum_transfer
    real(kind=8), dimension(num_layers) :: h_hat_l, h_hat_r
    real(kind=8) :: b_l, b_r, flux_transfer_l, flux_transfer_r, lambda(6)

    ! real(kind=8) :: advected_speed, eta_l, eta_r, gamma_l, gamma_r, kappa_l, kappa_r, w_normal, w_transverse

    ! Solver variables
    integer :: num_dry_states
    real(kind=8), dimension(num_layers) :: eigen_h_l, eigen_h_r
    real(kind=8), dimension(num_layers) :: eigen_u_l, eigen_u_r
    real(kind=8), dimension(num_layers) :: eigen_v_l, eigen_v_r
    real(kind=8), dimension(num_layers) :: flux_h_l, flux_h_r
    real(kind=8), dimension(num_layers) :: flux_hu_l, flux_hu_r
    real(kind=8), dimension(num_layers) :: flux_hv_l, flux_hv_r
    real(kind=8), dimension(num_layers) :: flux_u_l, flux_u_r
    real(kind=8), dimension(num_layers) :: flux_v_l, flux_v_r
    real(kind=8), dimension(6) :: delta, flux_r, flux_l, pivot
    real(kind=8), dimension(6,6) :: eig_vec, A
    real(kind=8) :: beta(6), alpha(4), fw(3, 3), sw(3)
    logical, dimension(num_layers) :: dry_state_l, dry_state_r
    logical :: inundation

    external dgesv

    interface
        subroutine solve_single_layer_rp(layer_index, h_l, h_r, hu_l, hu_r, hv_l, hv_r, b_l, b_r, fw, sw)
            use geoclaw_module, only: g => grav
            use multilayer_module, only: dry_tolerance
            implicit none
            ! Input
            integer, intent(in) :: layer_index
            real(kind=8), intent(in), dimension(2) :: h_l, h_r, hu_l, hu_r, hv_l, hv_r
            real(kind=8), intent(in) :: b_l, b_r
            ! Output
            real(kind=8), intent(in out) :: fw(3, 3), sw(3)
        end subroutine solve_single_layer_rp
    end interface

    ! Initialize output variables
    amdq = 0.d0
    apdq = 0.d0

    ! Set normal direction
    if (ixy == 1) then
        n_index = 2
        t_index = 3
    else
        n_index = 3
        t_index = 2
    endif

    ! ========================================================================
    ! Loop through Riemann problems
    ! ========================================================================
    do i=2-mbc,mx+mbc
        dry_state_l = .false.
        dry_state_r = .false.
        inundation = .false.

        ! Parse states and set appropriate zeros
        ! Note that the "u-direction" is the direction of sweeping which
        ! could actually be the x or y-directions depending on ixy

        do j=1,2
            layer_index = 3*(j-1)
            h_l(j) = qr(layer_index+1,i-1) / rho(j)
            hu_l(j) = qr(layer_index+n_index,i-1) / rho(j)
            hv_l(j) = qr(layer_index+t_index,i-1) / rho(j)

            h_r(j) = ql(layer_index+1,i) / rho(j)
            hu_r(j) = ql(layer_index+n_index,i) / rho(j)
            hv_r(j) = ql(layer_index+t_index,i) / rho(j)

            h_hat_l(j) = auxr(j+aux_layer_index-1,i-1)
            h_hat_r(j) = auxl(j+aux_layer_index-1,i)

            h_ave(:) = 0.5d0 * (h_l(:) + h_r(:))

            ! Check for dry states
            if (h_l(j) < dry_tolerance(j)) then
                dry_state_l(j) = .true.
                hu_l(j) = 0.d0
                hv_l(j) = 0.d0
                u_l(j) = 0.d0
                v_l(j) = 0.d0
            else
                u_l(j) = hu_l(j) / h_l(j)
                v_l(j) = hv_l(j) / h_l(j)
            endif
            if (h_r(j) < dry_tolerance(j)) then
                dry_state_r(j) = .true.
                hu_r(j) = 0.d0
                hv_r(j) = 0.d0
                u_r(j) = 0.d0
                v_r(j) = 0.d0
            else
                u_r(j) = hu_r(j) / h_r(j)
                v_r(j) = hv_r(j) / h_r(j)
            endif
        enddo

        b_l = auxr(1,i-1)
        b_r = auxl(1,i)

        ! For ease of checking below, count up number of dry states
        num_dry_states = 0
        do mw=1,2
            if (dry_state_l(mw)) then
                num_dry_states = num_dry_states + 1
            end if
            if (dry_state_r(mw)) then
                num_dry_states = num_dry_states + 1
            end if
        end do

        ! ===============================
        !  Completely dry cell - (T T T T)
        ! ===============================
        if (num_dry_states == 4) then
            s(:,i) = 0.d0
            fwave(:,:,i) = 0.d0

        ! ===============================================
        !  Single-layer problem -
        !   (T F T F) or (F T F T) or (F T T T) or
        !   (T F T T) or (T T F T) or (T T T F)
        ! ===============================================
        !  Here check explicitly for the completely wet single-layer cases and
        !  rely on the count to determine the other cases
        else if ((      dry_state_l(1) .and. .not. dry_state_l(2) .and.        &  ! T F T F
                        dry_state_r(1) .and. .not. dry_state_r(2))       .or.  &
                 (.not. dry_state_l(1) .and.       dry_state_l(2) .and.        &  ! F T F T
                  .not. dry_state_r(1) .and.       dry_state_r(2))       .or.  &
                 num_dry_states == 3) then

            ! Set wet layer index so that we can handle both the bottom and top
            ! layers being dry while the other is wet
            if (.not.dry_state_l(1) .or. .not.dry_state_r(1)) then
                layer_index = 1
            else if (.not.dry_state_l(2) .or. .not. dry_state_r(2)) then
                layer_index = 2
            else
                print *, "Invalid dry layer state reached."
                print *, "dry states: ", dry_state_l, dry_state_r
                print *, "        left            |             right"
                print *, "====================================================="
                print "(2d16.8)", h_l(1), h_r(1)
                print "(2d16.8)", hu_l(1), hu_r(1)
                print "(2d16.8)", hv_l(1), hv_r(1)
                print "(2d16.8)", h_l(2), h_r(2)
                print "(2d16.8)", hu_l(2), hu_r(2)
                print "(2d16.8)", hv_l(2), hv_r(2)
                print "(2d16.8)", b_l, b_r
                stop
            end if

            call solve_single_layer_rp(layer_index, h_l, h_r, hu_l, hu_r,      &
                                                    hv_l, hv_r, b_l, b_r,      &
                                                    fw, sw)

            ! Update speeds and waves
            ! Note that we represent all the waves in the first three arrays
            ! so it does not directly correspond to the two-layer case's wave
            ! structure
            s(:, i) = 0.d0
            fwave(:, :, i) = 0.d0

            if (layer_index == 1) then
                s(1:3, i) = sw(:)
                fwave(1, 1:3, i) = fw(1, :) * rho(layer_index)
                fwave(n_index, 1:3, i) = fw(2, :) * rho(layer_index)
                fwave(t_index, 1:3, i) = fw(3, :) * rho(layer_index)
            else
                s(4:6, i) = sw(:)
                fwave(1, 4:6, i) = fw(1, :) * rho(layer_index)
                fwave(n_index, 4:6, i) = fw(2, :) * rho(layer_index)
                fwave(t_index, 4:6, i) = fw(3, :) * rho(layer_index)
            end if

            ! Go on to next cell, lat-long and fluctuation calculations are
            ! outside of this loop

        ! ======================================================================
        !  Multi-layer system must be solved
        !   In each case a special eigen system is solved and then the flux
        !     difference is evaluated.
        !   Note that the parameter *eigen_method* controls the method being
        !     used if the cells are completely wet or there exists a wall
        !     boundary problem in the bottom layer.  Otherwise the parameter
        !     *inundation_method* is used.
        ! ======================================================================
        else
            ! By default fill in the eigen and flux evaluation states with their
            ! side values
            if (eigen_method == 1) then
                eigen_h_l = h_hat_l
                eigen_h_r = h_hat_r
            else
                eigen_h_l = h_l
                eigen_h_r = h_r
            end if
            eigen_u_l = u_l
            eigen_u_r = u_r
            eigen_v_l = v_l
            eigen_v_r = v_r

            flux_h_l = h_l
            flux_h_r = h_r
            flux_hu_l = hu_l
            flux_hu_r = hu_r
            flux_hv_l = hv_l
            flux_hv_r = hv_r
            flux_u_l = u_l
            flux_u_r = u_r
            flux_v_l = v_l
            flux_v_r = v_r

            ! Also intialize other flux evaluation stuff
            flux_transfer_r = 0.d0
            flux_transfer_l = 0.d0
            momentum_transfer = 0.d0

            ! ==================================================================
            !  Right state is completely dry - (F F T T)
            if (.not. dry_state_l(1) .and. .not. dry_state_l(2) .and.          &
                      dry_state_r(1) .and.       dry_state_r(2)) then

                ! Inundation occurs
                inundation = sum(h_l) + b_l > b_r
                if (inundation) then
                    print *, "Inundation in this case not yet handled."
                    print *, "  dry_state = ", dry_state_l, dry_state_r
                    stop

                ! Wall boundary
                else
                    ! Wall state - Mirror left state onto right
                    if (eigen_method /= 1) eigen_h_r = h_l
                    eigen_u_r = -u_l
                    eigen_v_r =  v_r

                    ! Flux evaluation
                    flux_h_r = h_l
                    flux_hu_r = -hu_l
                    flux_u_r = -u_l
                    flux_hv_r = hv_l
                    flux_v_r = v_l

                    flux_transfer_r = 0.d0
                    flux_transfer_l = 0.d0
                    momentum_transfer(1) = 0.d0
                    momentum_transfer(2) = 0.d0
                endif

            ! ==================================================================
            !  Left state is completely dry - (T T F F)
            else if (      dry_state_l(1) .and.       dry_state_l(2) .and.     &
                     .not. dry_state_r(1) .and. .not. dry_state_r(2)) then

                ! Inundation
                inundation = sum(h_r) + b_r > b_l
                if (inundation) then
                    print *, "Inundation in this case not yet handled."
                    print *, "  dry_state = ", dry_state_l, dry_state_r
                    stop

                ! Wall
                else
                    if (eigen_method /= 1) eigen_h_l = h_r
                    eigen_u_l = -u_r
                    eigen_v_l = v_l

                    ! Flux evaluation
                    flux_h_l = h_r
                    flux_hu_l = -hu_r
                    flux_u_l = -u_r
                    flux_hv_l = hv_r
                    flux_v_l = v_r

                    flux_transfer_r = 0.d0
                    flux_transfer_l = 0.d0
                    momentum_transfer(1) = 0.d0
                    momentum_transfer(2) = 0.d0

                end if

            ! ==================================================================
            !  Right bottom state is dry - (F F F T)
            else if (.not. dry_state_l(1) .and. .not. dry_state_l(2) .and.     &
                     .not. dry_state_r(1) .and.       dry_state_r(2)) then

                ! Inundation
                inundation = h_l(2) + b_l > b_r
                if (inundation) then
                    if (inundation_method == 1 .or.                            &
                        inundation_method == 4) then
                        eigen_h_r = [h_r(1), 0.d0]
                    else if (inundation_method == 2 .or.                       &
                             inundation_method == 3 .or.                       &
                             inundation_method == 5) then
                        eigen_h_r = [h_r(1), 0.d0]
                    end if

                    ! Flux evaluation
                    momentum_transfer(1) =  g * rho(1) * h_ave(1) * (h_r(2) - h_l(2) + b_r - b_l)
                    momentum_transfer(2) = -g * rho(1) * h_ave(1) * (h_r(2) - h_l(2)) + g * rho(2) * h_ave(2) * (b_r - b_l)
                    flux_transfer_r = g * rho(1) * h_r(1) * h_r(2)
                    flux_transfer_l = g * rho(1) * h_l(1) * h_l(2)

                ! Wall
                else
                    if (eigen_method /= 1) eigen_h_r = [h_r(1), 0.d0]
                    eigen_u_r = [u_r(1), -u_l(2)]
                    eigen_v_r = [v_r(1),  v_l(2)]

                    ! Flux evaluation
                    flux_h_r(2) = h_l(2)
                    flux_hu_r(2) = -hu_l(2)
                    flux_u_r(2) = -u_l(2)
                    flux_hv_r(2) = hv_l(2)
                    flux_v_r(2) = v_l(2)

                    flux_transfer_r = 0.d0
                    flux_transfer_l = 0.d0
                    momentum_transfer(1) = g * rho(1) * h_ave(1) * (b_r - flux_h_l(2) - b_l)
                    momentum_transfer(2) = 0.d0

                end if

            ! ==================================================================
            !  Left bottom state is dry - (F T F F)
            else if (.not. dry_state_l(1) .and.       dry_state_l(2) .and.     &
                     .not. dry_state_r(1) .and. .not. dry_state_r(2)) then

                ! Inundation
                inundation = (h_r(2) + b_r > b_l)
                if (inundation) then
                    if (inundation_method == 1 .or. inundation_method == 5) then
                        eigen_h_l = [h_l(1), 0.d0]
                    else if (inundation_method == 2 .or.                       &
                             inundation_method == 3 .or.                       &
                             inundation_method == 4) then
                        eigen_h_l = [h_l(1), dry_tolerance(1)]
                    end if

                    ! Flux evaluation
                    momentum_transfer(1) =  g * rho(1) * h_ave(1) * (h_r(2) - h_l(2) + b_r - b_l)
                    momentum_transfer(2) = -g * rho(1) * h_ave(1) * (h_r(2) - h_l(2)) + g * rho(2) * h_ave(2) * (b_r - b_l)
                    flux_transfer_r = g * rho(1) * h_r(1) * h_r(2)
                    flux_transfer_l = g * rho(1) * h_l(1) * h_l(2)

                ! Wall
                else
                    if (eigen_method /= 1) eigen_h_l = [h_l(1), 0.d0]
                    eigen_u_l = [u_l(1), -u_r(2)]
                    eigen_v_l = [v_l(1),  v_r(2)]

                    ! Flux evaluation
                    flux_h_l(2) = h_r(2)
                    flux_hu_l(2) = -hu_r(2)
                    flux_u_l(2) = -u_r(2)
                    flux_hv_l(2) = hv_r(2)
                    flux_v_l(2) = v_r(2)

                    flux_transfer_r = 0.d0
                    flux_transfer_l = 0.d0
                    momentum_transfer(1) = g * rho(1) * h_ave(1) * (b_r + flux_h_r(2) - b_l)
                    momentum_transfer(2) = 0.d0

                end if

            ! ==================================================================
            !  All-states are wet - (F F F F)
!             else if (.not. dry_state_l(1) .and. .not. dry_state_l(2) .and.     &
!                      .not. dry_state_r(1) .and. .not. dry_state_r(2)) then
            else if (num_dry_states == 0) then

                ! Nothing to do for eigenspace evaluation

                ! Flux evaulation
                momentum_transfer(1) =  g * rho(1) * h_ave(1) * (h_r(2) - h_l(2) + b_r - b_l)
                momentum_transfer(2) = -g * rho(1) * h_ave(1) * (h_r(2) - h_l(2)) + g * rho(2) * h_ave(2) * (b_r - b_l)
                flux_transfer_r = g * rho(1) * h_r(1) * h_r(2)
                flux_transfer_l = g * rho(1) * h_l(1) * h_l(2)

            ! ==================================================================
            !  We do not yet handle this case - F F F F and F F F F
            else
                print *, "Unhandled dry-state condition reached."
                print *, "dry states: ", dry_state_l, dry_state_r
                print *, "        left            |             right"
                print *, "====================================================="
                print "(2d16.8)", h_l(1), h_r(1)
                print "(2d16.8)", hu_l(1), hu_r(1)
                print "(2d16.8)", hv_l(1), hv_r(1)
                print "(2d16.8)", h_l(2), h_r(2)
                print "(2d16.8)", hu_l(2), hu_r(2)
                print "(2d16.8)", hv_l(2), hv_r(2)
                print "(2d16.8)", b_l, b_r
                stop
            end if

            ! ==================================================================
            !  Compute eigen space
            ! ==================================================================
            if (inundation) then
                call inundation_eigen_func(eigen_h_l, eigen_h_r,               &
                                           eigen_u_l, eigen_u_r,               &
                                           eigen_v_l, eigen_v_r,               &
                                           n_index, t_index,                   &
                                           lambda, eig_vec)

                ! Internal wave corrections
                if (inundation_method == 1) then
                    ! Left bottom state dry
                    if (.not. dry_state_l(1) .and.       dry_state_l(2) .and.  &
                        .not. dry_state_r(1) .and. .not. dry_state_r(2)) then

                        s(2,i) = u_r(2) - 2.d0 * sqrt(g*(1.d0-r)*h_r(2))
                        alpha(2) = r * g * h_r(2) / ((s(2,i) - u_r(2))**2 - g*h_r(2))
                        eig_vec(1,2) = 1.d0
                        eig_vec(n_index,2) = s(2,i)
                        eig_vec(t_index,2) = v_l(1)
                        eig_vec(4,2) = alpha(2)
                        eig_vec(n_index,2) = alpha(2)*s(2,i)
                        eig_vec(t_index,2) = alpha(2)*v_l(2)
                    ! Right bottom state dry
                    else if (.not. dry_state_l(1) .and. .not. dry_state_l(2) .and. &
                             .not. dry_state_r(1) .and.       dry_state_r(2)) then

                        s(5,i) = u_l(2) + 2.d0 * sqrt(g*(1.d0-r)*h_l(2))
                        alpha(3) = r * g * h_l(2) / ((s(5,i) - u_l(2))**2 - g * h_l(2))

                        eig_vec(1,5) = 1.d0
                        eig_vec(n_index,5) = s(i,5)
                        eig_vec(t_index,5) = v_r(1)
                        eig_vec(4,5) = alpha(3)
                        eig_vec(n_index,5) = s(i,5) * alpha(3)
                        eig_vec(t_index,6) = v_r(2) * alpha(3)
                    end if
                end if
                if (inundation_method /= 5) then
                    ! Left bottom state dry
                    if (.not. dry_state_l(1) .and.       dry_state_l(2) .and.  &
                        .not. dry_state_r(1) .and. .not. dry_state_r(2)) then

                        s(1,i) = u_l(1) - sqrt(g*h_l(1))
                        eig_vec(1,1) = 1.d0
                        eig_vec(n_index,1) = s(1,i)
                        eig_vec(t_index,1) = v_l(1)
                        eig_vec(4:6,1) = 0.d0

                    ! Right bottom state dry
                    else if (.not. dry_state_l(1) .and. .not. dry_state_l(2) .and. &
                             .not. dry_state_r(1) .and.       dry_state_r(2)) then

                        s(6,i) = u_r(1) + sqrt(g*h_r(1))
                        eig_vec(1,6) = 1.d0
                        eig_vec(n_index,6) = s(6,i)
                        eig_vec(t_index,6) = v_r(1)
                        eig_vec(4:6,6) = 0.d0

                    end if

                end if
            else
                call eigen_func(eigen_h_l, eigen_h_r,                    &
                                eigen_u_l, eigen_u_r,                    &
                                eigen_v_l, eigen_v_r,                    &
                                n_index, t_index,                        &
                                lambda, eig_vec)

            end if

            s(:,i) = lambda

            ! ======================================================================
            !  Compute flux differences
            ! ======================================================================
            do j=1,2
                layer_index = 3*(j-1)
                flux_r(layer_index+1) = rho(j) * flux_hu_r(j)
                flux_r(layer_index+n_index) = rho(j) * (flux_h_r(j) * flux_u_r(j)**2 + 0.5d0 * g * flux_h_r(j)**2)
                flux_r(layer_index+t_index) = rho(j) * flux_h_r(j) * flux_u_r(j) * flux_v_r(j)

                flux_l(layer_index+1) = rho(j) * flux_hu_l(j)
                flux_l(layer_index+n_index) = rho(j) * (flux_h_l(j) * flux_u_l(j)**2 + 0.5d0 * g * flux_h_l(j)**2)
                flux_l(layer_index+t_index) = rho(j) * flux_h_l(j) * flux_u_l(j) * flux_v_l(j)
            enddo
            ! Add extra flux terms
            flux_r(3 + n_index) = flux_r(3 + n_index) + flux_transfer_r
            flux_l(3 + n_index) = flux_l(3 + n_index) + flux_transfer_l

            delta = flux_r - flux_l

            ! Momentum transfer and bathy terms
            delta(n_index) = delta(n_index) + momentum_transfer(1)
            delta(n_index+3) = delta(n_index+3) + momentum_transfer(2)

            ! ======================================================================
            ! Project jump in fluxes - Use LAPACK's dgesv routine
            !    N - (int) - Number of linear equations (6)
            !    NRHS - (int) - Number of right hand sides (1)
            !    A - (dp(6,6)) - Coefficient matrix, in this case eig_vec
            !    LDA - (int) - Leading dimension of A (6)
            !    IPIV - (int(N)) - Pivot indices
            !    B - (dp(LDB,NRHS)) - RHS of equations (delta)
            !    LDB - (int) - Leading dimension of B (6)
            !    INFO - (int) - Status of result
            !  Note that the solution (betas) are in delta after the call
            ! ======================================================================
            A = eig_vec ! We need to do this as the return matrix is modified and
                        ! we have to use eig_vec again to compute fwaves
            info = 0
            call dgesv(6,1,A,6,pivot,delta,6,info)
            if (.not.(info == 0)) then
                print *, "dry states: ", dry_state_l, dry_state_r
                print *, "        left            |             right"
                print *, "====================================================="
                print "(2d16.8)", h_l(1), h_r(1)
                print "(2d16.8)", hu_l(1), hu_r(1)
                print "(2d16.8)", hv_l(1), hv_r(1)
                print "(2d16.8)", h_l(2), h_r(2)
                print "(2d16.8)", hu_l(2), hu_r(2)
                print "(2d16.8)", hv_l(2), hv_r(2)
                print "(2d16.8)", b_l, b_r
                print *,""
                print "(a,i2)","In normal solver: ixy=",ixy
                print "(a,i3)","  Error solving R beta = delta,",info
                print "(a,6d16.8)","  Eigenspeeds: ",s(:,i)
                print "(a)","  Eigenvectors:"
                do j=1,6
                    print "(a,6d16.8)","  ",(eig_vec(j,mw),mw=1,6)
                enddo
                stop
            endif
            beta = delta

            ! ======================================================================
            ! Compute fwaves
            forall(mw=1:mwaves)
                fwave(:,mw,i) = eig_vec(:,mw) * beta(mw)
            end forall
        end if

    end do
    ! == End of Riemann Solver Loop per grid cell ==============================

    ! ==========================================================================
    ! Capacity for mapping from latitude longitude to physical space
    if (mcapa > 0) then
        do i=2-mbc,mx+mbc
            if (ixy == 1) then
                dxdc=(earth_radius*pi/180.d0)
            else
                dxdc=auxl(3, i)
            endif

            do mw=1,mwaves
                s(mw,i)=dxdc*s(mw,i)
                fwave(:,mw,i)=dxdc*fwave(:,mw,i)
            enddo
        enddo
    endif

    ! ==========================================================================
    !  Compute fluctuations
    do i=2-mbc,mx+mbc
        do mw=1,mwaves
            if (s(mw,i) > 0.d0) then
                apdq(:,i) = apdq(:,i) + fwave(:,mw,i)
            else
                amdq(:,i) = amdq(:,i) + fwave(:,mw,i)
            endif
            !h_r(1) = ql(1,i) / rho(1)
            !h_l(1) = qr(1,i-1) / rho(1)
            !h_r(2) = ql(4,i) / rho(2)
            !h_l(2) = qr(4,i-1) / rho(2)
            !dry_state_r(2) = h_r(2) < dry_tolerance(2)
            !dry_state_l(2) = h_l(2) < dry_tolerance(2)
            !rare(1) = h_l(2) + b_l > b_r
            !rare(2) = h_r(2) + b_r > b_l
            !if (dry_state_r(2).and.(.not.dry_state_l(2)).and.(.not.rare(1)) &
            ! .or.(dry_state_l(2).and.(.not.dry_state_r(2)).and.(.not.rare(2)))) then
            !    do m=4,6
            !        if (abs(apdq(m,i)) <= 1.d-8) then
            !            print *,"========================"
            !            print *,"Wave ",mw," equation ",m
            !            print *,"s = ",s(mw,i)
            !            print *,"f = ",fwave(m,mw,i)
            !            print *,"amdq = ",(amdq(m,i))
            !            print *,"apdq = ",(apdq(m,i))
            !            stop "Fluctuation apdq non-zero going into a wall, aborting calculation."
            !        endif
            !    enddo
            !    apdq(4:6,i) = 0.d0
            !endif
        enddo
    enddo

end subroutine rpn2

! ==================================
!  Solve the single-layer equations
! ==================================
! subroutine solve_sinlge_layer_rp(layer_index, h_l, h_r,                        &
!                                               hu_l, hu_r,                      &
!                                               hv_l, hv_r,                      &
!                                               u_l, u_r,                        &
!                                               v_l, v_r,                        &
!                                               b_l, b_r,                        &
!                                               fw, sw)

!     use geoclaw_module, only: g => grav
!     use multilayer_module, only: dry_tolerance

!     implicit none

!     ! Input
!     integer, intent(in) :: layer_index
!     real(kind=8), intent(in out), dimension(2) :: h_l, h_r
!     real(kind=8), intent(in out), dimension(2) :: hu_l, hu_r
!     real(kind=8), intent(in out), dimension(2) :: hv_l, hv_r
!     real(kind=8), intent(in out), dimension(2) :: u_r, u_l
!     real(kind=8), intent(in out), dimension(2) :: v_r, v_l
!     real(kind=8), intent(in out) :: b_l, b_r

!     ! Output
!     real(kind=8), intent(out) :: fw(3, 3), sw(3)

!     ! Local storage
!     integer :: m, mw
!     logical :: rare(2)
!     real(kind=8) :: wall(3), h_star, h_star_test, sm(2)
!     real(kind=8) :: phi_l, phi_r, s_l, s_r, u_hat, c_hat, s_roe(2), s_E(2)

!     ! Algorithm parameters
!     integer, parameter :: MAX_ITERATIONS = 1

!     wall = 1.d0

!     ! Calculate momentum fluxes
!     phi_l = 0.5d0 * g * h_l(layer_index)**2      &
!                         + h_l(layer_index) * u_l(layer_index)**2
!     phi_r = 0.5d0 * g * h_r(layer_index)**2      &
!                         + h_r(layer_index) * u_r(layer_index)**2

!     ! Check for dry state to right
!     if (h_r(layer_index) < dry_tolerance(layer_index)) then
!         call riemanntype(h_l(layer_index), h_l(layer_index),   &
!                          u_l(layer_index),-u_l(layer_index),   &
!                          h_star, sm(1), sm(2), rare(1), rare(2), 1,    &
!                          dry_tolerance(layer_index), g)
!         h_star_test = max(h_l(layer_index), h_star)
!         ! Right state should become ghost values that mirror left for wall problem
!         if (h_star_test + b_l < b_r) then
!             wall(2:3) = 0.d0
!             h_r(layer_index) = h_l(layer_index)
!             hu_r(layer_index) = -hu_l(layer_index)
!             b_r = b_l
!             phi_r = phi_l
!             u_r(layer_index) = -u_l(layer_index)
!             v_r(layer_index) = v_l(layer_index)
!         else if (h_l(layer_index) + b_l < b_r) then
!             b_r = h_l(layer_index) + b_l
!         endif
!     ! Check for drystate to left, i.e right surface is lower than left topo
!     else if (h_l(layer_index) < dry_tolerance(layer_index)) then
!         call riemanntype(h_r(layer_index), h_r(layer_index),   &
!                         -u_r(layer_index), u_r(layer_index),   &
!                          h_star, sm(1), sm(2), rare(1), rare(2), 1,    &
!                          dry_tolerance(layer_index), g)
!         h_star_test = max(h_r(layer_index), h_star)
!         ! Left state should become ghost values that mirror right
!         if (h_star_test + b_r < b_l) then
!            wall(1:2) = 0.d0
!            h_l(layer_index) = h_r(layer_index)
!            hu_l(layer_index) = -hu_r(layer_index)
!            b_l = b_r
!            phi_l = phi_r
!            u_l(layer_index) = -u_r(layer_index)
!            v_l(layer_index) = v_r(layer_index)
!         else if (h_r(layer_index) + b_r < b_l) then
!            b_l = h_r(layer_index) + b_r
!         endif
!     endif

!     ! Determine wave speeds
!     ! 1 wave speed of left state
!     s_l = u_l(layer_index) - sqrt(g * h_l(layer_index))
!     ! 2 wave speed of right state
!     s_r = u_r(layer_index) + sqrt(g * h_r(layer_index))

!     ! Roe average
!     u_hat = (sqrt(g * h_l(layer_index)) * u_l(layer_index)     &
!            + sqrt(g * h_r(layer_index)) * u_r(layer_index))    &
!            / (sqrt(g * h_r(layer_index)) + sqrt(g * h_l(layer_index)))
!     c_hat = sqrt(g * 0.5d0 * (h_r(layer_index) + h_l(layer_index)))
!     s_roe(1) = u_hat - c_hat ! Roe wave speed 1 wave
!     s_roe(2) = u_hat + c_hat ! Roe wave speed 2 wave
!     s_E(1) = min(s_l, s_roe(1)) ! Eindfeldt speed 1 wave
!     s_E(2) = max(s_r, s_roe(2)) ! Eindfeldt speed 2 wave

!     ! Solve Riemann problem
!     call riemann_aug_JCP(MAX_ITERATIONS, 3, 3,                         &
!                          h_l(layer_index), h_r(layer_index),   &
!                          hu_l(layer_index), hu_r(layer_index), &
!                          hv_l(layer_index), hv_r(layer_index), &
!                          b_l, b_r,                                     &
!                          u_l(layer_index), u_r(layer_index),   &
!                          v_l(layer_index), v_r(layer_index),   &
!                          phi_l, phi_r, s_E(1), s_E(2),           &
!                          dry_tolerance(layer_index), g, sw, fw)

!     ! Eliminate ghost fluxes for wall
!     do mw=1,3
!         sw(mw) = sw(mw) * wall(mw)
!         do m=1,3
!            fw(m, mw) = fw(m, mw) * wall(mw)
!         enddo
!     enddo

! end subroutine solve_sinlge_layer_rp

subroutine solve_single_layer_rp(layer_index, h_l, h_r, hu_l, hu_r, hv_l, hv_r, b_l, b_r, fw, sw)

    use geoclaw_module, only: g => grav
    use multilayer_module, only: dry_tolerance

    implicit none

    ! Input
    integer, intent(in) :: layer_index
    real(kind=8), intent(in), dimension(2) :: h_l, h_r, hu_l, hu_r, hv_l, hv_r
    real(kind=8), intent(in) :: b_l, b_r

    ! Output
    real(kind=8), intent(in out) :: fw(3, 3), sw(3)

    ! Locals
    integer :: mw
    real(kind=8) :: hL, hR, huL, huR, hvL, hvR, uL, uR, vL, vR, bL, bR
    real(kind=8) :: phiL, phiR, wall(3), drytol
    real(kind=8) :: hstar, hstartest, s1m, s2m, rare1, rare2, sL, sR, uhat, chat, sRoe1, sRoe2, sE1, sE2

    ! Parameters (should be anyway)
    integer :: maxiter

    drytol = dry_tolerance(layer_index)

    hL = h_l(layer_index)
    hR = h_r(layer_index)
    huL = hu_l(layer_index)
    huR = hu_r(layer_index)
    hvL = hv_l(layer_index)
    hvR = hv_r(layer_index)
    bL = b_l
    bR = b_r

    ! ========================================
    !  Begin Snipped Code From rpn2_geoclaw.f
    ! ========================================
    !check for wet/dry boundary
         if (hR.gt.drytol) then
            uR=huR/hR
            vR=hvR/hR
            phiR = 0.5d0*g*hR**2 + huR**2/hR
         else
            hR = 0.d0
            huR = 0.d0
            hvR = 0.d0
            uR = 0.d0
            vR = 0.d0
            phiR = 0.d0
         endif

         if (hL.gt.drytol) then
            uL=huL/hL
            vL=hvL/hL
            phiL = 0.5d0*g*hL**2 + huL**2/hL
         else
            hL=0.d0
            huL=0.d0
            hvL=0.d0
            uL=0.d0
            vL=0.d0
            phiL = 0.d0
         endif

         wall(1) = 1.d0
         wall(2) = 1.d0
         wall(3) = 1.d0
         if (hR.le.drytol) then
            call riemanntype(hL,hL,uL,-uL,hstar,s1m,s2m,rare1,rare2,1,drytol,g)
            hstartest=max(hL,hstar)
            if (hstartest+bL.lt.bR) then !right state should become ghost values that mirror left for wall problem
!                bR=hstartest+bL
               wall(2)=0.d0
               wall(3)=0.d0
               hR=hL
               huR=-huL
               bR=bL
               phiR=phiL
               uR=-uL
               vR=vL
            elseif (hL+bL.lt.bR) then
               bR=hL+bL
            endif
         elseif (hL.le.drytol) then ! right surface is lower than left topo
            call riemanntype(hR,hR,-uR,uR,hstar,s1m,s2m,rare1,rare2,1,drytol,g)
            hstartest=max(hR,hstar)
            if (hstartest+bR.lt.bL) then  !left state should become ghost values that mirror right
!               bL=hstartest+bR
               wall(1)=0.d0
               wall(2)=0.d0
               hL=hR
               huL=-huR
               bL=bR
               phiL=phiR
               uL=-uR
               vL=vR
            elseif (hR+bR.lt.bL) then
               bL=hR+bR
            endif
         endif

         !determine wave speeds
         sL=uL-sqrt(g*hL) ! 1 wave speed of left state
         sR=uR+sqrt(g*hR) ! 2 wave speed of right state

         uhat=(sqrt(g*hL)*uL + sqrt(g*hR)*uR)/(sqrt(g*hR)+sqrt(g*hL)) ! Roe average
         chat=sqrt(g*0.5d0*(hR+hL)) ! Roe average
         sRoe1=uhat-chat ! Roe wave speed 1 wave
         sRoe2=uhat+chat ! Roe wave speed 2 wave

         sE1 = min(sL,sRoe1) ! Eindfeldt speed 1 wave
         sE2 = max(sR,sRoe2) ! Eindfeldt speed 2 wave

         !--------------------end initializing...finally----------
         !solve Riemann problem.

         maxiter = 1

         call riemann_aug_JCP(maxiter,3,3,hL,hR,huL,huR,hvL,hvR,bL,bR,uL,uR, &
                                          vL,vR,phiL,phiR,sE1,sE2,drytol,g,sw,fw)

!         call riemann_ssqfwave(maxiter,meqn,mwaves,hL,hR,huL,huR,
!     &     hvL,hvR,bL,bR,uL,uR,vL,vR,phiL,phiR,sE1,sE2,drytol,g,sw,fw)

!          call riemann_fwave(meqn,mwaves,hL,hR,huL,huR,hvL,hvR,
!     &      bL,bR,uL,uR,vL,vR,phiL,phiR,sE1,sE2,drytol,g,sw,fw)

!        !eliminate ghost fluxes for wall
         do mw=1,3
            sw(mw)=sw(mw)*wall(mw)

               fw(1,mw)=fw(1,mw)*wall(mw)
               fw(2,mw)=fw(2,mw)*wall(mw)
               fw(3,mw)=fw(3,mw)*wall(mw)
         enddo

end subroutine solve_single_layer_rp


! { dg-do compile }
! { dg-require-visibility "" }

module general_rand
  implicit none
  private

  integer, public, parameter :: GNDP = kind(1.0d0)

  real(kind = GNDP), save :: &
    gnc = 362436.0 / 16777216.0, &
    gncd = 7654321.0 / 16777216.0, &
    gncm = 16777213.0 / 16777216.0
  integer, save :: &
    gni97 = 97, &
    gnj97 = 33

  real(kind = GNDP), save :: gnu(97)

contains
  subroutine gn_fatal(message)
    character(len = *), intent(in) :: message

    stop 1
  end subroutine gn_fatal

  function gn_monte_rand(min, max) result(monte)
    real(kind = GNDP), intent(in) :: min
    real(kind = GNDP), intent(in) :: max
    real(kind = GNDP) :: monte

    real :: monte_temp

    if (min > max) then
      call gn_fatal('gn_monte_rand: min > max')
    else if (min == max) then
      call gn_fatal('gn_monte_rand: min = max: returning min')
      monte_temp = min
    else

      monte_temp = gnu(gni97) - gnu(gnj97)
      if (monte_temp < 0.0) then
        monte_temp = monte_temp + 1.0
      end if

      gnu(gni97) = monte_temp
      gni97 = gni97 - 1
      if (gni97 == 0) then
        gni97 = 97
      end if
    end if

    monte = min + monte_temp * (max - min)

  end function gn_monte_rand

end module general_rand


! { dg-do run }
! { dg-require-effective-target fortran_large_real }

  implicit none
  integer,parameter :: k = selected_real_kind (precision (0.0_8) + 1)
  integer :: i
  real(k) :: qda1(10), qda(10), qval

  qda = (/ 1,2,3,4,5,6,7,8,9,10 /)
  QDA1 = MOD (1.1_k*(QDA(1)-5.0_k), P=(QDA-2.5_k))
  DO i = 1, 10
    QVAL = MOD (1.1_k*(QDA(1)-5.0_k), P=(QDA(i)-2.5_k))
    if (qval /= qda1(i)) STOP 1
  enddo
end


module adi2DMethod
    use linearSystemSolver
    use globVariables
      IMPLICIT NONE

      INTEGER  :: n,m,Nt
      INTEGER :: np,mp
      INTEGER :: niter_x,niter_x_glob
      INTEGER :: niter_y,niter_y_glob
      REAL, dIMENSION(:,:), ALLOCATABLE :: mesh_init
      REAL, dIMENSION(:,:), ALLOCATABLE :: mesh_sol
      REAL  ::  cl_north,cl_south,cl_east,cl_west
      REAL  :: alpha, lambda,rho,dif,cap
      REAL :: init_value
      REAL  ::  dim_x , delta_x, dim_y,  delta_y , dim_t, delta_t
      INTEGER :: time_step
      INTEGER :: rest_x,rest_y

      CONTAINS

!*************************************************************************
! subroutine
!  name : read data
!*************************************************************************

subroutine adi_2d_read_data()
 INTEGER :: stat
 character(len=100) :: line

      dim_x = .0
      dim_y = .0
      dim_t = .0
      n = 0
      m = 0
      rho = .0
      cap = .0
      lambda = .0
      cl_east = .0
      cl_west = .0
      cl_south = .0
      cl_north = .0

  DO WHILE (.TRUE.)
              READ(READ_UNIT, *, IOSTAT=stat) line
              IF(IS_IOSTAT_END(stat)) EXIT

           SELECT CASE (line)

               case("GEOMETRY_RECTANGLE")

                      READ(READ_UNIT,*) dim_x,dim_y

               case("CARTESIAN_GRID")

                      READ(READ_UNIT,*) n,m

               case("TIME_DEPENDANT")

                      READ(READ_UNIT,*) dim_t, time_step

               case("BOUNDARY_CONDITION")

                      READ(READ_UNIT,*) cl_east,cl_west,cl_north, cl_south

               case ("INIT_ALL_GRID")

                      READ(READ_UNIT,*) init_value

                case ("PHYSICS_HEAT")

                      READ(READ_UNIT,*) lambda,rho,cap

                case default

                      write(WRITE_UNIT,*) "unknown data set element"

                end select

      enddo

      close(READ_UNIT)
! control

  if ( lambda == .0 .or. rho == .0 .or. cap == .0 ) then
                                write(*,*) "bad constants"
                                call mpi_finalize(ierr)
                                call exit
  endif

 if ( dim_t == .0 .or. time_step == 0 ) then

                                write(*,*) "bad time discretization"
                                call mpi_finalize(ierr)
                                call exit
      endif

 if ( n == 0 .or. m == 0 ) then
                              write(*,*) "bad domain discretization"
                              call mpi_finalize(ierr)
                              call exit
 endif

  if ( dim_x == .0 .or. dim_y == .0 ) then
                              write(*,*) "bad domain definition"
                              call mpi_finalize(ierr)
                              call exit
   endif

      delta_x = dim_x/(1.0*n)
      delta_y = dim_y/(1.0*m)
      delta_t = dim_t/(1.0*time_step)
      dif = lambda/(rho*cap)

      if ( rank == 0 ) then
      write(WRITE_UNIT,*) "HEAT EQUATION SOLVER"
      write(WRITE_UNIT,*) "parameters of the equation :"
      write(WRITE_UNIT,*) "thermal diffusivity :" , dif , "m^2/s"
      write(WRITE_UNIT,*) "------------------------------------------------------------------"
      endif

end subroutine

!*************************************************************************
! subroutine
! name : start_solver
!*************************************************************************

 subroutine adi_2d_start_solver()

if ( rank == 0 ) then
write(WRITE_UNIT,*) "         number of points to compute : ", (n-2)*(m-2)
write(WRITE_UNIT,*) "         number of process : " , numprocs
write(WRITE_UNIT,*) "------------------------------------------------------------------"

endif

! x direction
         niter_x_glob = (m-2)/numprocs
         rest_x = mod((m-2),numprocs)

         if ( rank .lt. rest_x ) then
            niter_x = niter_x_glob +1
         else
            niter_x = niter_x_glob
         endif

         mp = niter_x+2

! y direction

         niter_y_glob = (n-2)/numprocs
         rest_y = mod((n-2),numprocs)

         if ( rank .lt. rest_y ) then
            niter_y = niter_y_glob +1
         else
            niter_y = niter_y_glob
         endif

         np = niter_y+2

         call adi_2d_simulation()

end subroutine

!*************************************************************************
! subroutine
! name : mesh_initilialization
!*************************************************************************

subroutine adi_2d_mesh_initialization()

                mesh_init = init_value
                mesh_init(:,1) = cl_west
                mesh_init(:,m) = cl_east

           if ( rank == 0 ) then
                mesh_init(1,:) = cl_north
           endif

           if ( rank == numprocs-1 ) then
                mesh_init(np,:) = cl_south
           endif

end subroutine

!*************************************************************************
! subroutine :
! name : adi method
!*************************************************************************

subroutine adi_2d_simulation()
integer BUFSIZE, thefile
integer(kind=MPI_OFFSET_KIND) disp
REAL, dimension(:,:), allocatable ::  local_mesh
REAL, dimension(:,:), allocatable ::  mesh_write
REAL, dimension(:,:), allocatable ::  matrix
INTEGER :: i,j,i_step,mini,maxi
REAL, dimension(:), allocatable ::  tab
INTEGER :: nb,ne,mb,me
INTEGER :: niter_send,np_send, niter_receiv
INTEGER :: mesh_init_cursor, local_mesh_cursor, write_cursor
INTEGER :: offset
INTEGER :: nl,nc,TS,NUMB

if ( rank == 0 ) then
write(WRITE_UNIT,*) "method of resolution : Alternating direction implicit method (2-D)"
write(WRITE_UNIT,*) "------------------------------------------------------------------"
endif

allocate(mesh_init(np,m))

call adi_2d_mesh_initialization()

! We create a binary file to save the results of the calculation in parallel
! each task will write his results in a specific location of the file :

call MPI_FILE_OPEN(MPI_COMM_WORLD, 'testfile', &
             MPI_MODE_WRONLY + MPI_MODE_CREATE, &
                     MPI_INFO_NULL, thefile, ierr)

disp = 0

! meta data  -> time step
    call MPI_FILE_WRITE_AT_ALL(thefile,disp,time_step,1, MPI_INTEGER, &
                        MPI_STATUS_IGNORE, ierr)

disp = disp + 4

 !meta data  -> number of blocks by time edition

    call MPI_FILE_WRITE_AT_ALL(thefile,disp,numprocs-1,1, MPI_INTEGER, &
                        MPI_STATUS_IGNORE, ierr)

do i_step = 1,time_step

offset = (i_step-1)*(n*m + numprocs*2) + 2
offset = offset*4

! x direction

allocate ( matrix(m-2,m-2) )
allocate (tab(m-2))
allocate ( local_mesh(np,m) )

local_mesh(1,:) = mesh_init(1,:)
local_mesh(np,:) = mesh_init(np,:)
local_mesh(2:np-1,m) = mesh_init(2:np-1,m)
local_mesh(2:np-1,1) = mesh_init(2:np-1,1)

           do i =2,niter_y+1
               CALL adi_2d_arrays_init(1,i,tab,matrix)
               CALL lapack_solver(matrix,tab,m-2,1)
               local_mesh(i,2:m-1) = tab
           enddo

deallocate(matrix)
deallocate(tab)

! y direction calculation initialization
! We set the local boundary conditions :

deallocate(mesh_init)
allocate(mesh_init(n,mp))
mesh_init(1,:) = cl_north
mesh_init(n,:) = cl_south

local_mesh_cursor = 1
mesh_init_cursor = 2

do i=0,numprocs-1

      if ( rest_x /= 0 ) then
        if ( i >= rest_x ) then
           niter_send = niter_x_glob
        else
           niter_send = niter_x_glob +1
        endif
      else
           niter_send = niter_x_glob
      endif

         if ( rest_y /= 0 ) then
        if ( i >= rest_y ) then
           niter_receiv = niter_y_glob
        else
           niter_receiv = niter_y_glob +1
        endif
      else
           niter_receiv = niter_y_glob
      endif

! Déplacement horizontal sur la grille : local_mesh

         mb = local_mesh_cursor
         local_mesh_cursor = local_mesh_cursor + niter_send
         me = local_mesh_cursor + 1

! Déplacement vertical sur la grille : mesh_init

         nb = mesh_init_cursor
         mesh_init_cursor = mesh_init_cursor + niter_receiv
         ne =  mesh_init_cursor -1

        if ( i == rank ) then
                 mesh_init(nb:ne,1:mp) = local_mesh(2:np-1,mb:me)
                 write_cursor = nb
        else
                call MPI_Sendrecv(local_mesh(2:np-1,mb:me),niter_y*(niter_send+2),MPI_REAL,i,rank+101,&
                mesh_init(nb:ne,1:mp),niter_receiv*mp, MPI_REAL,i,i+101,MPI_COMM_WORLD,status,ierr)
        endif

enddo

deallocate(local_mesh)

allocate ( matrix(n-2,n-2) )

allocate (tab(n-2))
allocate(local_mesh(n,mp))

local_mesh(1,:) = mesh_init(1,:)
local_mesh(n,:) = mesh_init(n,:)
local_mesh(2:n-1,mp) = mesh_init(2:n-1,mp)
local_mesh(2:n-1,1) = mesh_init(2:n-1,1)

            do i =2,niter_x+1
               CALL adi_2d_arrays_init(2,i,tab,matrix)
               CALL lapack_solver(matrix,tab,n-2,1)
               local_mesh(2:n-1,i) = tab
            enddo

deallocate( matrix )
deallocate( tab )

deallocate(mesh_init)
allocate(mesh_init(np,m))
mesh_init(:,m) = cl_east
mesh_init(:,1)  = cl_west

local_mesh_cursor = 2
mesh_init_cursor = 1

do i=0,numprocs-1

   if ( rest_y /= 0 ) then
        if ( i >= rest_y ) then
           niter_send = niter_y_glob
        else
           niter_send = niter_y_glob +1
        endif
      else
           niter_send = niter_y_glob
      endif

          if ( rest_x /= 0 ) then
        if ( i >= rest_x ) then
           niter_receiv = niter_x_glob
        else
           niter_receiv = niter_x_glob +1
        endif
      else
           niter_receiv = niter_x_glob
      endif

! Déplacement horizontal sur la grille : mesh_init

         mb = local_mesh_cursor
         local_mesh_cursor = local_mesh_cursor + niter_receiv
         me = local_mesh_cursor - 1

! Déplacement vertical sur la grille : local_mesh

         nb = mesh_init_cursor
         mesh_init_cursor = mesh_init_cursor + niter_send
         ne =  mesh_init_cursor +1

        if ( i == rank ) then
           mesh_init(1:np,mb:me) = local_mesh(nb:ne,2:mp-1)
        else
              call MPI_Sendrecv(local_mesh(nb:ne,2:mp-1),niter_x*(niter_send+2),MPI_REAL,i,rank+101,&
              mesh_init(1:np,mb:me),niter_receiv*np, MPI_REAL,i,i+101,MPI_COMM_WORLD,status,ierr)
        endif

enddo

deallocate( local_mesh )

! now we save the results in the binary file

     BUFSIZE = niter_y
     nb = 2
     ne = np-1

    if ( rank == 0 ) then
       BUFSIZE = BUFSIZE + 1
       nb = 1
       write_cursor = 1
    endif
   if ( rank == numprocs-1) then
        BUFSIZE = BUFSIZE + 1
        ne = np
   endif

      disp = (write_cursor-1)*m*4 + offset + rank*8

! meta data
! number of lines in block
    call MPI_FILE_SET_VIEW(thefile,disp, MPI_INTEGER, &
                           MPI_INTEGER, 'native', &
                           MPI_INFO_NULL, ierr)
    call MPI_FILE_WRITE(thefile,BUFSIZE,1, MPI_INTEGER, &
                        MPI_STATUS_IGNORE, ierr)

                disp = disp + 4

! number of columns in block

    call MPI_FILE_SET_VIEW(thefile,disp, MPI_INTEGER, &
                           MPI_INTEGER, 'native', &
                           MPI_INFO_NULL, ierr)
    call MPI_FILE_WRITE(thefile,m,1, MPI_INTEGER, &
                        MPI_STATUS_IGNORE, ierr)

                disp = disp + 4

! data
       BUFSIZE = BUFSIZE*m

     call MPI_FILE_SET_VIEW(thefile, disp, MPI_REAL, &
                           MPI_REAL, 'native', &
                           MPI_INFO_NULL, ierr)
    call MPI_FILE_WRITE(thefile,mesh_init(nb:ne,:),BUFSIZE, MPI_REAL, &
                        MPI_STATUS_IGNORE, ierr)

 if ( rank == 0 ) then
 write(WRITE_UNIT,*) "calculation time step", i_step , "finished"
endif

enddo

 deallocate(mesh_init)

 call MPI_FILE_CLOSE(thefile, ierr)

end subroutine

!*************************************************************************
! subroutine :
! name : adi init method
!*************************************************************************

subroutine adi_2d_arrays_init(step,line,tab,matrix)
INTEGER :: step
REAL :: tab(:)
REAL :: matrix(:,:)
INTEGER, INTENT(IN)  :: line
INTEGER :: i,j

matrix =0.
tab =0.

if ( step == 1) then

        alpha = (dif*delta_t)/(2.0*delta_x*delta_x)

do i = 1,m-2
   do j=1,m-2

   if ( i == j ) then
         matrix(i,j) = 1.0 +2.0*alpha
      end if
      if (j == i+1 .and. i < m-2 ) then
         matrix(i,j) = -1.0*alpha
      end if
      if (  j == i-1 .and. i>1 ) then
         matrix(i,j) = -1.0*alpha
      end if
    enddo
enddo

! time
     tab(:) = (1-2.0*alpha)*mesh_init(line,2:m-1)

! top side
     tab(:) = tab(:) + 1.0*alpha*mesh_init(line-1,2:m-1)

! lower side
     tab(:) = tab(:) + 1.0*alpha*mesh_init(line+1,2:m-1)

! left side
     tab(1) = tab(1) +  1.0*alpha*mesh_init(line,1)

! right side
     tab(m-2) = tab(m-2) +  1.0*alpha*mesh_init(line,m)
endif

if ( step == 2) then

        alpha = (dif*delta_t)/(2.0*delta_y*delta_y)

 do i = 1,n-2
   do j=1,n-2

    if ( i == j ) then
         matrix(i,j) = 1.0 +2.0*alpha
      end if
      if (j == i+1 .and. i < n-2 ) then
         matrix(i,j) = -1.0*alpha
      end if
      if (  j == i-1 .and. i>1 ) then
         matrix(i,j) = -1.0*alpha
      end if
    enddo
enddo

! time
     tab(:) = (1-2.0*alpha)*mesh_init(2:n-1,line)
! left side
     tab(:) = tab(:) + 1.0*alpha*mesh_init(2:n-1,line-1)
! right side
     tab(:) = tab(:) + 1.0*alpha*mesh_init(2:n-1,line+1)
! top of the grid
     tab(1) = tab(1) +  1.0*alpha*mesh_init(1,line)
! bottom of the grid
     tab(n-2) = tab(n-2) +  1.0*alpha*mesh_init(n,line)
endif

end subroutine

end module


C=======================================================================
C  DATES, File, Nigel Pickering, G. Hoogenboom, P.W. Wilkens and B. Baer
C  General functions related to time and date calculations
C-----------------------------------------------------------------------
C  REVISION HISTORY
C  09/13/1991 NBP Developed
C  01/30/1998 GH  Modified ENDYR function for leap year
C  01/30/1998 GH  Added NAILUJ routine
C  02/02/1998 GH  Integer in YR_DOY
C  07/01/2000 GH  Added INCDAT
C  06/09/2002 GH  Modified for Y2K
C  11/29/2004 CHP Added ETAD_NAILUJ for Ponding routine -- provides
C                   integer month given date.
!  10/11/2005 CHP Fix problem in Y2K_DOYW, sequenced runs spanning Y2K
!  11/16/2007 CHP Added leap year function
C=======================================================================
C=======================================================================
C  DOYC, Integer function, N.B. Pickering, 09/13/91
C  Calculates "TRUE" julian day, assuming that all leap years are
C  divisible by 4. This is incorrect for certain years.
C-----------------------------------------------------------------------
C  09/13/1991 NBP Devfeloped
C  11/24/2002 GH  Modified for Y2K
C-----------------------------------------------------------------------
C  Input : YR,DOY
C  Output: DOC
C  Local : NLEAP
C=======================================================================

      INTEGER FUNCTION DOYC(YR,DOY)

      IMPLICIT NONE
      INTEGER DOY,NLEAP,YR

      NLEAP = INT((YR-1)/4)
      DOYC = NLEAP*366 + (YR-NLEAP-1)*365 + DOY

      END FUNCTION DOYC

C=======================================================================
C  YR_DOY, Subroutine, N.B. Pickering, 09/13/91
C  Converts YRDOY to YR and DOY.
C-----------------------------------------------------------------------
C  Input : YRDOY
C  Output: YR,DOY
C=======================================================================

      SUBROUTINE YR_DOY(YRDOY,YR,DOY)

      IMPLICIT NONE

      INTEGER DOY,YR,YRDOY

      YR  = INT(YRDOY / 1000)
      DOY = YRDOY - YR * 1000

      END SUBROUTINE YR_DOY

C=======================================================================
C  Y2K_DOY, Subroutine, Gerrit Hoogenboom 6/7/2002
C  Converts YRDOY to Y2K
C-----------------------------------------------------------------------
C  Input : YRDOY
C  Output: YRDOY
C=======================================================================

      SUBROUTINE Y2K_DOY(YRDOY)

      IMPLICIT NONE

      INTEGER DOY,YR,YRDOY

      IF (YRDOY .LE. 99365) THEN
        YR  = INT(YRDOY / 1000)
        DOY = YRDOY - YR * 1000
        IF (YRDOY .GT. 0) THEN
!     CHP 09/11/2009 - change "cross-over" year from 2010 to 2015
!     CHP 03/26/2014 - change "cross-over" year from 2015 to 2020
!     CHP 07/06/2017 - change "cross-over" year from 2020 to 2025
          IF (YR .LE. 25) THEN
            YRDOY = (2000 + YR) * 1000 + DOY
          ELSE
            YRDOY = (1900 + YR) * 1000 + DOY
          ENDIF
        ENDIF
      ENDIF

      END SUBROUTINE Y2K_DOY

C=======================================================================
C  Y2K_DOYW, Subroutine, C. Porter, 02/05/2004
C  Converts YRDOYW to Y2K for weather files
C  If this is a sequenced run, then days are forced to be sequential
C    when going from year 2010 to 2011,
C    and from 1999 to 2000.
! 09/11/2009 CHP changed "cross-over" year from 2010 to 2015
C-----------------------------------------------------------------------
C  Input : RNMODE, YRDOYWY, YRDOYW
C  Output: YRDOYW
C=======================================================================

      SUBROUTINE Y2K_DOYW(MULTI, YRDOYWY, YRDOYW, CENTURY)

      USE ModuleDefs
      IMPLICIT NONE

!      CHARACTER*1 RNMODE
      INTEGER MULTI   !, RUN
      INTEGER CENTURY,  DOY,  YEAR,  YR,  YRDOYW
      INTEGER CENTURYY, DOYY, YEARY, YRY, YRDOYWY !, YRINC

      DATA YRY /0/

      IF (MULTI .LE. 1) YRY = 0

      IF (YRDOYW .LE. 99365) THEN
        YR  = INT(YRDOYW / 1000)
        DOY = YRDOYW - YR * 1000

        IF (YRDOYW .GT. 0) THEN
!!         IF (YR .LE. 10 .OR. YRY .GE. 2000) THEN
!          IF (YR .LE. 15 .OR. YRY .GE. 2000) THEN
!            CENTURY = 20
!          ELSE
!            CENTURY = 19
!          ENDIF
          YEAR = CENTURY * 100 + YR
          YRDOYW = YEAR * 1000 + DOY
        ENDIF
      ELSE
        CALL YR_DOY(YRDOYW, YEAR, DOY)
        CENTURY = INT(YEAR / 100)
      ENDIF

      CALL YR_DOY(YRDOYWY, YEARY, DOYY)
      CENTURYY = INT(YEARY / 100)

!-----------------------------------
!!     RNMODE = Q CHECK RUN
!!     RNMODE = N CHECK MULTI
!!CHP 10/11/2005 Fix problem with sequenced runs spanning Y2K
!!CHP 10/9/06      IF (INDEX('QFNS',RNMODE) .GT. 0 .OR. MULTI .GT. 1) THEN
!      IF ((INDEX('QF',RNMODE) > 0 .AND. RUN   > 1) .OR.
!!     &    (INDEX('N', RNMODE) > 0 .AND. MULTI > 1)) THEN
!     &    (MULTI > 1)) THEN
!
!        YRINC = YEAR - YEARY
!!       IF (YRINC .EQ. 100 .OR. YRINC .EQ. 101) THEN
!        IF (YRINC .GT. 1) THEN
!          YEAR = YEAR - 100
!          YRDOYW = YEAR * 1000 + DOY
!        ELSEIF (YRINC .LT. 0) THEN
!          YEAR = YEAR + 100
!          YRDOYW = YEAR * 1000 + DOY
!        ENDIF
!      ENDIF

!     10/10/2006 CHP
!     Fixes problem with model going from 2010 to 1911 during simulation
      IF (CENTURYY > CENTURY) THEN
        CENTURY = CENTURYY
        YEAR = CENTURY * 100 + YR
        YRDOYW = YEAR * 1000 + DOY

!     Fixes problem with crossing centuries
      ELSEIF (CENTURYY == CENTURY .AND.
     &        YEAR < YEARY .AND. MOD(YEARY,100) == 99) THEN
        CENTURY = CENTURY + 1
        YEAR = CENTURY * 100 + YR
        YRDOYW = YEAR * 1000 + DOY
      ENDIF

      RETURN
      END SUBROUTINE Y2K_DOYW

C=======================================================================
C  YDOY, Integer Function, N.B. Pickering, 09/13/91
C  Converts YR and DOY to YRDOY.
C-----------------------------------------------------------------------
C  Input : YR,DOY
C  Output: YRDOY
C=======================================================================

      INTEGER FUNCTION YDOY(YR,DOY)

      IMPLICIT NONE
      INTEGER DOY,YR

      YDOY = YR * 1000 + DOY

      END FUNCTION YDOY

C=======================================================================
C  TIMDIF, Integer function, N.B. Pickering, 09/13/91
C  Calculates the time difference between two YRDOY dates (days).
C-----------------------------------------------------------------------
C  Input : YRDOY1,YRDOY2
C  Output: DAYDIF
C=======================================================================

      INTEGER FUNCTION TIMDIF(YRDOY1,YRDOY2)

      IMPLICIT NONE
      INTEGER DOYC,DOY1,DOY2,YR1,YR2,YRDOY1,YRDOY2

C     Simple time difference of two days in the same year attempted first.

      TIMDIF = YRDOY2 - YRDOY1

C     If time difference involves a year change, use DOC calculations.

      IF (TIMDIF .GT. 365 .OR. TIMDIF .LT. -365) THEN
        CALL YR_DOY(YRDOY1,YR1,DOY1)
        CALL YR_DOY(YRDOY2,YR2,DOY2)
        TIMDIF = DOYC(YR2,DOY2) - DOYC(YR1,DOY1)
      ENDIF

      END FUNCTION TIMDIF

C=======================================================================
C  MTHEND, Integer Function, N.B. Pickering, 06/05/92
C  Calculates day-of-year that is end of month.
C-----------------------------------------------------------------------
C  Input : MTH,YR
C  Output: MTHEND
C  Local : MEND,LEAPYR
C=======================================================================

      INTEGER FUNCTION MTHEND(YR,MTH)

      IMPLICIT NONE
      INTEGER MTH,MEND(12),YR
      LOGICAL LEAP
      DATA MEND/31,59,90,120,151,181,212,243,273,304,334,365/

      IF (LEAP(YR) .AND. MTH.GE.2) THEN
        MTHEND = MEND(MTH) + 1
      ELSE
        MTHEND = MEND(MTH)
      ENDIF

      END FUNCTION MTHEND

C=======================================================================
C  MTHMID, Integer Function, N.B. Pickering, 06/05/92
C  Calculates day-of-year that is midpoint of month.
C-----------------------------------------------------------------------
C  Input : MTH,YR
C  Output: MTHMID
C  Local : MAXDOY,MBEG,MEND,LEAPYR,MTHBEG,MTHEND
C=======================================================================

      INTEGER FUNCTION MTHMID(YR,MTH)

      IMPLICIT NONE
      INTEGER MTH,YR
      LOGICAL LEAP
      INTEGER MIDPT(12)
      DATA MIDPT/16,46,75,106,136,167,197,228,259,289,320,350/

      IF (LEAP(YR) .AND. MTH.GE.2) THEN
        MTHMID = MIDPT(MTH) + 1
      ELSE
        MTHMID = MIDPT(MTH)
      ENDIF

      END FUNCTION MTHMID

C=======================================================================
C  INCYD, Integer Function, N.B. Pickering, 06/05/92
C  Increases/decreases YRDOY based on INC (ABS(INC)<=365).
C-----------------------------------------------------------------------
C  Input : YRDOY
C  Output: INCYD
C  Local : YDEND,YR,DOY
C=======================================================================

      INTEGER FUNCTION INCYD(YRDOY,INC)

      IMPLICIT NONE
      INTEGER ENDYR,INC,NDYR,YRDOY,YR,DOY,YDOY

      CALL YR_DOY(YRDOY,YR,DOY)
      NDYR = ENDYR(YR)
      DOY = DOY + INC
      IF (DOY .GT. NDYR) THEN
        YR = YR + 1
        DOY = DOY - NDYR
      ELSE IF (DOY .LE. 0) THEN
        YR = YR - 1
        NDYR = ENDYR(YR)
        DOY = NDYR + DOY
      ENDIF
      INCYD = YDOY(YR,DOY)

      END FUNCTION INCYD

C=======================================================================
C  INCDAT, Integer Function,J.Hansen
C  Similar to INCYD without the restriction that DELTA <= 365.
C-----------------------------------------------------------------------
C  Input : YRDOY(ADATE)
C  Output: INCDAT
C  Local : NDYR,AYR,ADOY,DELTA,ENDYR,YDOY
C-----------------------------------------------------------------------

      INTEGER FUNCTION INCDAT(ADATE, DELTA)

      IMPLICIT NONE
      INTEGER NDYR, AYR, ADOY, ADATE, DELTA, ENDYR, YDOY
      EXTERNAL ENDYR, YDOY

      CALL YR_DOY(ADATE, AYR, ADOY)
      NDYR = ENDYR(AYR)
      ADOY = ADOY + DELTA
  100 CONTINUE
      IF (ADOY .GT. NDYR) THEN
        AYR = AYR + 1
        ADOY = ADOY - NDYR
        GO TO 100
      END IF
  200 IF (ADOY .LE. 0) THEN
        AYR = AYR - 1
        NDYR = ENDYR(AYR)
        ADOY = ADOY + NDYR
        GO TO 200
      END IF
      INCDAT = YDOY(AYR, ADOY)

      RETURN
      END FUNCTION INCDAT

C=======================================================================
C  INCMTH, Integer Function, N.B. Pickering, 06/05/92
C  Increases/decreases month and adjusts YR based on INC (ABS(INC)<=12).
C-----------------------------------------------------------------------
C  Input : YR,MTH,SIGN
C  Output: INCMTH
C  Local :
C=======================================================================

      SUBROUTINE INCMTH(YR,MTH,INC)

      INTEGER YR,MTH,INC

      MTH = MTH + INC
      IF (MTH .GT. 12) THEN
        YR = YR + 1
        MTH = MTH - 12
      ELSE IF (MTH .LT. 1) THEN
        YR = YR - 1
        MTH = MTH + 12
      ENDIF

      END SUBROUTINE INCMTH

C=======================================================================
C  YDEND, Integer Function, N.B. Pickering, 06/05/92
C  Computes end-of-year in YRDOY format.  Input can be YRDOY or YR.
C-----------------------------------------------------------------------
C  Input : YRDOY or YR
C  Output: YDEND
C  Local : DOY,NDYR,YR
C=======================================================================

      INTEGER FUNCTION YDEND(YRDOY)

      IMPLICIT NONE
      INTEGER ENDYR,YRDOY,YR,YDOY

      IF (YRDOY/1000 .NE. 0) THEN
        YR = YRDOY / 1000
      ELSE
        YR = YRDOY
      ENDIF
      YDEND = YDOY(YR,ENDYR(YR))

      END FUNCTION YDEND

C=======================================================================
C  ENDYR, Integer Function, N.B. Pickering, 06/05/92
C  Computes end-of-year (365 or 366) depending if leap year.
C-----------------------------------------------------------------------
C  Input : YR
C  Output: ENDYR
C  Local :
C=======================================================================

      INTEGER FUNCTION ENDYR(YR)

      INTEGER YR
      LOGICAL LEAP

      IF (LEAP(YR)) THEN; ENDYR = 366
      ELSE;               ENDYR = 365
      ENDIF

      END FUNCTION ENDYR

C=======================================================================
C  JULIAN, Function
C
C  Determines day, month
C-----------------------------------------------------------------------
C  Revision history
C
C  1. Written
C  2  Modified by
C  3. Header revision and minor changes             P.W.W.      5-28-93
C-----------------------------------------------------------------------
C  INPUT  : NDAY,RMON,NYRCHK
C
C  LOCAL  : MonthTxt,UPCASE,I,JCOUNT,DAYS
C
C  OUTPUT : JULIAN
C-----------------------------------------------------------------------
C  Called : SEHARV SEPLT SETIME
C
C  Calls  : None
C-----------------------------------------------------------------------
C                         DEFINITIONS
C
C  RMON   :
C  MonthTxt():
C  UPCASE :
C  I      :
C  JCOUNT :
C  NDAY   :
C  NYRCHK :
C  DAYS()  :
C=======================================================================

      INTEGER FUNCTION JULIAN (NDAY,RMON,YR)

      USE ModuleDefs
      IMPLICIT    NONE

      CHARACTER*3 RMON    !,MonthTxt(12)
      CHARACTER*1 UPCASE

      INTEGER     I,JCOUNT,NDAY,YR,DAYS(12)
      LOGICAL     LEAP

      DATA DAYS   /31,28,31,30,31,30,31,31,30,31,30,31/
!      DATA MonthTxt /'JAN','FEB','MAR','APR','MAY','JUN',
!     &            'JUL','AUG','SEP','OCT','NOV','DEC'/

      IF (LEAP(YR)) THEN; DAYS(2) = 29
      ELSE; DAYS(2) = 28
      ENDIF

      DO I = 1, 3
         RMON(I:I) = UPCASE(RMON(I:I))
      END DO
      DO JCOUNT = 1, 12
         IF (RMON .EQ. MonthTxt(JCOUNT)) GO TO 200
      END DO

C-----------------------------------------------------------------------
C     Month name cannot be recognized
C-----------------------------------------------------------------------

      JULIAN = 370
      RETURN
  200 JULIAN = 0

      DO 400 JCOUNT = 1, 12
           IF (RMON .EQ. MonthTxt(JCOUNT))
     &          GO TO 300
           JULIAN = JULIAN + DAYS(JCOUNT)
           GO TO 400
  300      JULIAN = JULIAN + NDAY
           RETURN
  400 CONTINUE

      END FUNCTION JULIAN

C=======================================================================
C  NAILUJ, Subroutine
C
C  Determines Julian date
C-----------------------------------------------------------------------
C  Revision history
C
C  1. Written
C  2  Modified by
C  3. Header revision and minor changes             P.W.W.      5-28-93
C-----------------------------------------------------------------------
C  INPUT  : JULD,NYRCHK
C
C  LOCAL  : MonthTxt(),NSUM,JCOUNT,NDIF,DAYS()
C
C  OUTPUT : NDAY RMON
C-----------------------------------------------------------------------
C  Called : SEHARV SENS SEPLT SETIME OPDAY OPHEAD
C
C  Calls  : None
C-----------------------------------------------------------------------
C                         DEFINITIONS
C
C  RMON   :
C  MonthTxt():
C  NSUM   :
C  JCOUNT :
C  NDIF   :
C  JULD   :
C  NYRCHK :
C  NDAY   :
C  DAYS()  :
C=======================================================================

      SUBROUTINE NAILUJ (JULD,YR,RMON,NDAY)

      USE ModuleDefs
      IMPLICIT    NONE

      CHARACTER*3 RMON    !,MonthTxt(12)
      INTEGER     NSUM,JCOUNT,NDIF,JULD,YR,NDAY,DAYS(12)
      LOGICAL     LEAP

      DATA DAYS   /31,28,31,30,31,30,31,31,30,31,30,31/
!      DATA MonthTxt /'JAN','FEB','MAR','APR','MAY','JUN',
!     &            'JUL','AUG','SEP','OCT','NOV','DEC'/

      IF (LEAP(YR)) THEN; DAYS(2) = 29
      ELSE; DAYS(2) = 28
      ENDIF

      NSUM = 0

      DO JCOUNT = 1, 12
         NDIF = JULD - NSUM
         IF (NDIF .LE. DAYS(JCOUNT)) THEN
            NDAY = NDIF
            RMON = MonthTxt(JCOUNT)
            RETURN
         ENDIF
         NSUM = NSUM + DAYS(JCOUNT)
      END DO

      RETURN

      END SUBROUTINE NAILUJ

C=======================================================================
C  FullYear, Subroutine
C
C  Converts 2 digit year to 4 digit year. On first call per simulation,
C    assumes that years 10 and lower refer to 2010 and years 11 and higher
C    refer to 1911.  After the first call, years are converted based on
C    previous years (i.e., year 2011 follows year 2010.)
C
C-----------------------------------------------------------------------
C  Revision history
C
C  02/07/2002 CHP Written
C  11/24/2002 GH  Modified Y2K to 10
C=======================================================================
      SUBROUTINE FullYear (YRDOY, YEAR, DOY)

      IMPLICIT    NONE

      INTEGER CENTURY, DOY
      INTEGER YEAR, YRDOY, YR
      LOGICAL FIRST
      DATA FIRST /.TRUE./

      IF (YRDOY .LE. 99365) THEN
        YR  = INT(YRDOY / 1000)
        DOY = YRDOY - YR * 1000

        IF (FIRST) THEN
          IF (YR .LE. 20) THEN
            CENTURY = 2000
          ELSE
            CENTURY = 1900
          ENDIF
          FIRST = .FALSE.
        ENDIF

!       This will work if the YRDOY after 99365 is 100001.
         YEAR = CENTURY + YR

      ENDIF
      RETURN
      END SUBROUTINE FullYear

C=======================================================================
C  ETAD_NAILUJ, Subroutine
C
C  Determines Julian date, exports integer year, month, day
C-----------------------------------------------------------------------
C  Revision history
C
C  11/29/2004 CHP Written based on NAILUJ
C-----------------------------------------------------------------------
C  INPUT  : JULD
C  OUTPUT : YR, iMON, NDAY
C=======================================================================

      SUBROUTINE ETAD_NAILUJ (JULD, YR, iMON, NDAY)

      IMPLICIT    NONE

      INTEGER     NSUM,NDIF,JULD,YR,NDAY,DAYS(12), iMON
      LOGICAL     LEAP

      DATA DAYS   /31,28,31,30,31,30,31,31,30,31,30,31/

      IF (LEAP(YR)) THEN; DAYS(2) = 29
      ELSE;               DAYS(2) = 28
      ENDIF

      NSUM = 0

      DO iMON = 1, 12
         NDIF = JULD - NSUM
         IF (NDIF .LE. DAYS(iMON)) THEN
            NDAY = NDIF
            RETURN
         ENDIF
         NSUM = NSUM + DAYS(iMON)
      END DO

      RETURN

      END SUBROUTINE ETAD_NAILUJ

C=======================================================================

C=======================================================================
C  LEAP, Function
C
C  Determines leap years
C-----------------------------------------------------------------------
C  Revision history
C
C  11/16/2007 CHP Written
C-----------------------------------------------------------------------
C  INPUT  : YR
C  OUTPUT : LEAP
C=======================================================================

      LOGICAL FUNCTION LEAP (YR)

      IMPLICIT    NONE
      INTEGER YR

      IF     (MOD(YR,400) == 0) THEN; LEAP = .TRUE.
      ELSEIF (MOD(YR,100) == 0) THEN; LEAP = .FALSE.
      ELSEIF (MOD(YR,  4) == 0) THEN; LEAP = .TRUE.
      ELSE;                           LEAP = .FALSE.
      ENDIF

      RETURN
      END FUNCTION LEAP

C=======================================================================


program constantes
implicit none

real, parameter :: G=6.67e-11
integer, parameter :: k=8
complex, parameter :: Z=(1.0,0.5)
!parameter es un atributo que se le da al dato, haciendolo corr

print*, "El valor de la constante G es:"
print*,G

print*,"el valor de la constante K es"
print*,k

print*, "el valor de la constante z es:"
print*,Z

Pause

end program constantes


C  *********************************************************
C  *                                                       *
C  *    TEST NUMBER: 06.02.01/01                           *
C  *    TEST TITLE : Behavior of orientation utilities     *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      COMMON /GLOBNU/ CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT, DUMRL
      INTEGER         CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT(20), ERRIND
      REAL    DUMRL(20)

      COMMON /GLOBCH/ PIDENT,    GLBERR,    TSTMSG,     FUNCID,
     1                DUMCH
      CHARACTER       PIDENT*40, GLBERR*60, TSTMSG*900, FUNCID*80,
     1                DUMCH(20)*20

C  Declare program-specific variables

      REAL       VWRX, VWRY, VWRZ, VPNX, VPNY, VPNZ, VUPX, VUPY, VUPZ
      REAL       ACT4X4(4,4), EXP4X4(4,4), ACT3X3(3,3), EXP3X3(3,3)

      LOGICAL    TRNSEQ

      CHARACTER  MSG*300

      CALL INITGL ('06.02.01/01')

C open PHIGS
      CALL XPOPPH (ERRFIL, MEMUN)

      CALL SETMSG ('1 2 3 4', '<Evaluate view orientation matrix 3> ' //
     1             'should return a correct representation for the '  //
     2             'transformation to change 3D WC coordinates to '   //
     3             '3D VRC coordinates.')

C  Set 3D orientation parameters (all WC x-y-z):
C    VRP (view reference point) :  -3.24, 37.727,  11.2
C    VPN (view plane normal)    :  62.21, 45.67,  -25.98
C    VUP (view up vector)       : -23.32,  6.868,  -2.22
      VWRX = -3.24
      VWRY = 37.727
      VWRZ = 11.2
      VPNX = 62.21
      VPNY = 45.67
      VPNZ = -25.98
      VUPX = -23.32
      VUPY =  6.868
      VUPZ = -2.22

C  <Evaluate view orientation matrix 3> returns act4x4 = actual array
      CALL PEVOM3 (VWRX,VWRY,VWRZ, VPNX,VPNY,VPNZ, VUPX,VUPY,VUPZ,
     1             ERRIND, ACT4X4)
      IF (ERRIND .EQ. 0) THEN
C  Compute exp4x4 = expected array
         CALL EEVOM3 (VWRX,VWRY,VWRZ, VPNX,VPNY,VPNZ, VUPX,VUPY,VUPZ,
     1                EXP4X4)
         CALL IFPF (TRNSEQ (4, ACT4X4, EXP4X4))
      ELSE
         CALL FAIL
         WRITE (MSG,'(A,I5)') 'PEVOM3 failed with error code = ', ERRIND
         CALL INMSG (MSG)
      ENDIF

      CALL SETMSG ('1 2 5 6', '<Evaluate view orientation matrix> '   //
     1             'should return a correct representation for the '  //
     2             'transformation to change 2D WC coordinates to '   //
     3             '2D VRC coordinates.')

C  Set 2D orientation parameters (all WC x-y):
C    VRP (view reference point) :  -3.24, 37.727
C    VUP (view up vector)       : -23.32,  0.041
      VWRX = -3.24
      VWRY = 37.727
      VUPX = -23.32
      VUPY = 0.041

C  <Evaluate view orientation matrix> returns act3x3 = actual array
      CALL PEVOM (VWRX,VWRY, VUPX,VUPY, ERRIND, ACT3X3)
      IF (ERRIND .EQ. 0) THEN
C  Compute exp3x3 = expected array
         CALL EEVOM (VWRX,VWRY, VUPX,VUPY, EXP3X3)
         CALL IFPF (TRNSEQ (3, ACT3X3, EXP3X3))
      ELSE
         CALL FAIL
         WRITE (MSG,'(A,I5)') 'PEVOM failed with error code = ', ERRIND
         CALL INMSG (MSG)
      ENDIF

666   CONTINUE
      CALL ENDIT
      END


!
  module thetadata_mod
    logical :: prop=.true.
    integer :: npoiarg,iunitarg=741
    double precision :: argmin,argstepinv
    double precision, dimension(:), allocatable :: argvals,thetavals
  end module thetadata_mod
!
!ccccccccccccccccccccccccccccccccccccccccccccccccccc
!
  subroutine attenuation_factor(D,Theta)
!
  use thetadata_mod
  USE polylag_3,  ONLY : mp,indef, plag1d
!
  implicit none
!
  integer :: i
  double precision :: D,Theta,arglog,fun,der
  integer,          dimension(mp) :: indu
  double precision, dimension(mp) :: xp,fp
!
  if(prop) then
    prop=.false.
    open(iunitarg,file='thetafun_inp.dat')
    npoiarg=0
    do
      read(iunitarg,*,end=1) arglog
      npoiarg=npoiarg+1
    enddo
1   close(iunitarg)
    allocate(argvals(npoiarg),thetavals(npoiarg))
    open(iunitarg,file='thetafun_inp.dat')
    do i=1,npoiarg
      read(iunitarg,*) arglog,Theta
      argvals(i)=log(arglog)
      thetavals(i)=log(Theta)
    enddo
    close(iunitarg)
    argmin=argvals(1)
    argstepinv=1.d0/(argvals(2)-argvals(1))
  endif
!
  arglog=log(D)
!
  call indef(arglog,argmin,argstepinv,npoiarg,indu)
!
  xp=argvals(indu)
  fp=thetavals(indu)
!
  call plag1d(arglog,fp,argstepinv,xp,fun,der)
!
  Theta=exp(fun)
!
  end subroutine attenuation_factor


!  *******************************************************************
!  *                                                                 *
!  *                       subroutine dsifa                          *
!  *                                                                 *
!  *******************************************************************
!  Double Precision Version 08/14/78 1.01
!  Written by James Bunch, Univ. Calif. San Diego, Argonne Nat. Lab.
!  Modified by Gordon A. Fenton, Aug. 24, 1993.
!  Latest Update: Jun 9, 1999
!
!  PURPOSE  factors a double precision symmetric matrix by elimination
!           with symmetric pivoting
!
!     To solve  A*X = B ,          follow dsifa by dsisl.
!
!     On entry
!
!        A       double precision(lda,n)
!                the symmetric matrix to be factored.
!                only the diagonal and upper triangle are used.
!
!        lda     integer
!                the leading dimension of the array  a .
!
!        n       integer
!                the order of the matrix  a .
!
!     on return
!
!        A       a block diagonal matrix and the multipliers which
!                were used to obtain it.
!                the factorization can be written  a = u*d*trans(u)
!                where  u  is a product of permutation and unit
!                upper triangular matrices , trans(u) is the
!               transpose of  u , and  d  is block diagonal
!               with 1 by 1 and 2 by 2 blocks.
!
!       kpvt    integer(n)
!               an integer vector of pivot indices.
!
!       ierr    integer
!               = 0  if all goes well.
!               = k  if the k-th pivot block is singular. this is
!                    not an error condition for this subroutine,
!                    but it does indicate that dsisl or dsidi may
!                    divide by zero if called.
!
! Requires:
!   1) from libGAFsim:	DAXPY, DSWAP, IDAMAX
!
! REVISION HISTORY:
! 1.01	replaced dummy dimensions with a (*) for GNU's compiler (Jun 9/99)
!------------------------------------------------------------------------
      subroutine dsifa(a,lda,n,kpvt,ierr)
      implicit real*8 (a-h,o-z)
      dimension a(lda,*)
      integer kpvt(*)
      logical swap
      data zero/0.d0/, one/1.d0/, eight/8.d0/, svtn/17.d0/

!						choose pivot block size.
      alpha = (one + dsqrt(svtn))/eight
      ierr  = 0
!						loop on k, from n to 1.
      k = n
!						leave the loop if k=0 or k=1.
  10  if (k .eq. 0) return
      if (k .eq. 1) then
         kpvt(1) = 1
         if (a(1,1) .eq. zero) ierr = 1
         return
      endif
      km1 = k - 1
      absakk = dabs(a(k,k))
!						largest element in col k
      imax = idamax(k-1,a(1,k))
      colmax = dabs(a(imax,k))
      if (absakk .ge. alpha*colmax) then
         kstep = 1
         swap = .false.
      else
!						largest element in row imax
         rowmax = zero
         imaxp1 = imax + 1
         do 20 j = imaxp1, k
            rowmax = dmax1(rowmax,dabs(a(imax,j)))
  20     continue
         if (imax .ne. 1) then
            jmax = idamax(imax-1,a(1,imax))
            rowmax = dmax1(rowmax,dabs(a(jmax,imax)))
         endif
         if (dabs(a(imax,imax)) .ge. alpha*rowmax) then
            kstep = 1
            swap = .true.
         else
            if (absakk .ge. alpha*colmax*(colmax/rowmax)) then
               kstep = 1
               swap = .false.
            else
               kstep = 2
               swap = imax .ne. km1
            endif
         endif
      endif
      if (dmax1(absakk,colmax) .eq. zero) then
!						column k is zero.  set ierr
         kpvt(k) = k
         ierr = k
      elseif (kstep .eq. 1) then
!						1 x 1 pivot block.
         if (swap) then
            call dswap(imax,a(1,imax),a(1,k))
            do 30 jj = imax, k
               j = k + imax - jj
               t = a(j,k)
               a(j,k) = a(imax,j)
               a(imax,j) = t
  30        continue
         endif
!						perform the elimination.
         do 40 jj = 1, km1
            j = k - jj
            amk = -a(j,k)/a(k,k)
            t = amk
            call daxpy(j,t,a(1,k),a(1,j))
            a(j,k) = amk
  40     continue
!	     				set the pivot array.
         kpvt(k) = k
         if (swap) kpvt(k) = imax
      else
!						2 x 2 pivot block.
         if (swap) then
            call dswap(imax,a(1,imax),a(1,k-1))
            do 50 jj = imax, km1
               j = km1 + imax - jj
               t = a(j,k-1)
               a(j,k-1) = a(imax,j)
               a(imax,j) = t
  50        continue
            t = a(k-1,k)
            a(k-1,k) = a(imax,k)
            a(imax,k) = t
         endif
!						perform the elimination.
         km2 = k - 2
         if (km2 .ne. 0) then
            ak = a(k,k)/a(k-1,k)
            akm1 = a(k-1,k-1)/a(k-1,k)
            denom = one - ak*akm1
            do 60 jj = 1, km2
               j = km1 - jj
               bk = a(j,k)/a(k-1,k)
               bkm1 = a(j,k-1)/a(k-1,k)
               amk = (akm1*bk - bkm1)/denom
               amkm1 = (ak*bkm1 - bk)/denom
               t = amk
               call daxpy(j,t,a(1,k),a(1,j))
               t = amkm1
               call daxpy(j,t,a(1,k-1),a(1,j))
               a(j,k) = amk
               a(j,k-1) = amkm1
  60        continue
         endif
!            				set the pivot array.
         kpvt(k) = 1 - k
         if (swap) kpvt(k) = -imax
         kpvt(k-1) = kpvt(k)
      endif
      k = k - kstep
      go to 10

      end


! STRUMPACK -- STRUctured Matrices PACKage, Copyright (c) 2014, The
! Regents of the University of California, through Lawrence Berkeley
! National Laboratory (subject to receipt of any required approvals
! from the U.S. Dept. of Energy).  All rights reserved.
!
! If you have questions about your rights to use or distribute this
! software, please contact Berkeley Lab's Technology Transfer
! Department at TTD@lbl.gov.
!
! NOTICE. This software is owned by the U.S. Department of Energy. As
! such, the U.S. Government has been granted for itself and others
! acting on its behalf a paid-up, nonexclusive, irrevocable,
! worldwide license in the Software to reproduce, prepare derivative
! works, and perform publicly and display publicly.  Beginning five
! (5) years after the date permission to assert copyright is obtained
! from the U.S. Department of Energy, and subject to any subsequent
! five (5) year renewals, the U.S. Government is granted for itself
! and others acting on its behalf a paid-up, nonexclusive,
! irrevocable, worldwide license in the Software to reproduce,
! prepare derivative works, distribute copies to the public, perform
! publicly and display publicly, and to permit others to do so.
!
! Developers: Pieter Ghysels, Francois-Henry Rouet, Xiaoye S. Li.
!             (Lawrence Berkeley National Lab, Computational Research
!             Division).

program fstructured
  use, intrinsic :: ISO_C_BINDING
  use strumpack_dense
  implicit none

  integer(C_INT) :: n        ! matrix dimension
  integer(C_INT) :: nrhs     ! number of right hand sides
  integer :: r, c, i         ! row, column, index
  integer(C_INT) :: ierr

  ! dense Toeplitz matrix
  ! real(C_DOUBLE), dimension(:,:), allocatable, target :: T
  COMPLEX*16, dimension(:,:), allocatable, target :: T

  ! solution and right hand-side vectors (matrices)
  !real(C_DOUBLE), dimension(:,:), allocatable, target :: X, B
  COMPLEX*16, dimension(:,:), allocatable, target :: X, B

  ! structured matrix options structure
  type(CSPOptions) :: options

  ! structured matrix
  type(C_PTR) :: S

  n = 1000
  nrhs = 10
  write(*,*) "# Creating a ", n, "x", n, " Toeplitz matrix"

  allocate( T( n, n ) )

  ! construct a simple (dense) test matrix
  do c = 1, n
     do r = 1, n
        T( r, c ) = 1. / (1. + abs(r - c))
     end do
  end do

  allocate( B( n, nrhs ) )
  allocate( X( n, nrhs ) )

  do c = 1, nrhs
     do r = 1, n
        X( r, c ) = 1. / n
     end do
  end do

  call SP_d_struct_default_options( options )
  options%type = SP_TYPE_HSS

  ! construct a rank-structured matrix from T
  ierr = SP_z_struct_from_dense( S, n, n, c_loc(T(1, 1)), n, options )

  ! compute the right-hand side B from X as B = H*X
  ierr = SP_z_struct_mult( S, 'N', nrhs, c_loc(X(1, 1)), n, c_loc(B(1, 1)), n )

  ! compute a factorization of H
  ierr = SP_z_struct_factor( S )

  ! solve linear system H * X = B
  write(*,*) "# solving linear system"
  ierr = SP_z_struct_solve( S, nrhs, c_loc(B(1, 1)), n )

  ! TODO check accuracy of compression, solve

  call SP_z_struct_destroy( S )

  deallocate(T)
  deallocate(X)
  deallocate(B)

end program fstructured


module tridiagxvector_interface
  interface
    subroutine tridiagxvector(ad, al, au, v, w)
      real, dimension(:), intent(in) :: ad, al, au, v
      real, dimension(:), intent(out) :: w
    end subroutine
  end interface
end module