program Interface_test
    use Sherman_Morrison
    use Helpers
    implicit none

    integer i, j, col !! Iterators
    integer(c_int) :: Dim, N_updates
    integer(c_int), dimension(:), allocatable :: Updates_index
    real(c_double), dimension(:,:), allocatable :: S, A, Updates
    real(c_double), dimension(:,:), allocatable :: S_inv, S_inv_t, A_inv

    Dim = 4
    N_updates = 2
    allocate( S(Dim,Dim), S_inv(Dim,Dim), S_inv_t(Dim,Dim), A(Dim,Dim), A_inv(Dim,Dim), &
              Updates(Dim,N_updates), Updates_index(N_updates))

    !! Initialize S, S_inv, A and A_inv
    S(1,1) = 1.0d0
    S(1,2) = 0.0d0
    S(1,3) = 1.0d0
    S(1,4) = -1.0d0
    S(2,1) = 0.0d0
    S(2,2) = 1.0d0
    S(2,3) = 1.0d0
    S(2,4) = 0.0d0
    S(3,1) = -1.0d0
    S(3,2) = 0.0d0
    S(3,3) = -1.0d0
    S(3,4) = 0.0d0
    S(4,1) = 1.0d0
    S(4,2) = 1.0d0
    S(4,3) = 1.0d0
    S(4,4) = 1.0d0

    S_inv(1,1) = 1.0d0
    S_inv(1,2) = -1.0d0
    S_inv(1,3) = 1.0d0
    S_inv(1,4) = 1.0d0
    S_inv(2,1) = 1.0d0
    S_inv(2,2) = 0.0d0
    S_inv(2,3) = 2.0d0
    S_inv(2,4) = 1.0d0
    S_inv(3,1) = -1.0d0
    S_inv(3,2) = 1.0d0
    S_inv(3,3) = -2.0d0
    S_inv(3,4) = -1.0d0
    S_inv(4,1) = -1.0d0
    S_inv(4,2) = 0.0d0
    S_inv(4,3) = -1.0d0
    S_inv(4,4) = 0.0d0

    A(1,1) = 1.0d0
    A(1,2) = 0.0d0
    A(1,3) = 1.0d0
    A(1,4) = -1.0d0
    A(2,1) = 0.0d0
    A(2,2) = -1.0d0
    A(2,3) = 1.0d0
    A(2,4) = -1.0d0
    A(3,1) = -1.0d0
    A(3,2) = 0.0d0
    A(3,3) = -1.0d0
    A(3,4) = 0.0d0
    A(4,1) = 1.0d0
    A(4,2) = 1.0d0
    A(4,3) = 1.0d0
    A(4,4) = 1.0d0

    A_inv(1,1) = 0.0d0
    A_inv(1,2) = -1.0d0
    A_inv(1,3) = -2.0d0
    A_inv(1,4) = -1.0d0
    A_inv(2,1) = 1.0d0
    A_inv(2,2) = 0.0d0
    A_inv(2,3) = 2.0d0
    A_inv(2,4) = 1.0d0
    A_inv(3,1) = 0.0d0
    A_inv(3,2) = 1.0d0
    A_inv(3,3) = 1.0d0
    A_inv(3,4) = 1.0d0
    A_inv(4,1) = -1.0d0
    A_inv(4,2) = 0.0d0
    A_inv(4,3) = -1.0d0
    A_inv(4,4) = 0.0d0

    !! Prepare Updates and Updates_index
    Updates(1,1) = 0
    Updates(1,2) = 0
    Updates(2,1) = -2
    Updates(2,2) = -1
    Updates(3,1) = 0
    Updates(3,2) = 0
    Updates(4,1) = 0
    Updates(4,2) = 0

    Updates_index(1) = 2
    Updates_index(2) = 4

    !! Write current S and S_inv to file for check in Octave
    open(unit = 2000, file = "Slater_old.dat")
    open(unit = 3000, file = "Slater_old_inv.dat")
    do i=1,dim
        do j=1,dim
            write(2000,"(E23.15, 1X)", advance="no") S(i,j)
            write(3000,"(E23.15, 1X)", advance="no") S_inv(i,j)
        end do
        write(2000,*)
        write(3000,*)
    end do
    close(2000)
    close(3000)

    !! Write Updates to file to check
    open(unit = 2000, file = "Updates.dat")
    do i=1,dim
        do j=1,n_updates
            write(2000,"(E23.15, 1X)", advance="no") Updates(i,j)
        end do
        write(2000,*)
    end do
    close(2000)

    !! Update S
    do i=1,N_updates
        do j=1,Dim
            col = Updates_index(i)
            S(j,col) = S(j,col) + Updates(j,i)
        end do
    end do

    !! Update S_inv
    call Transpose(S_inv, S_inv_t, Dim)
    call MaponiA3(S_inv_t, Dim, N_updates, Updates, Updates_index)
    call Transpose(S_inv_t, S_inv, Dim)

    !! Write new S and S_inv to file for check in Octave
    open(unit = 4000, file = "Slater.dat")
    open(unit = 5000, file = "Slater_inv.dat")
    do i=1,dim
        do j=1,dim
            write(4000,"(E23.15, 1X)", advance="no") S(i,j)
            write(5000,"(E23.15, 1X)", advance="no") S_inv(i,j)
        end do
        write(4000,*)
        write(5000,*)
    end do
    close(4000)
    close(5000)

    deallocate(Updates_index, A, A_inv, S, Updates, S_inv)
end program


module modu

contains
    integer function add_integer(a, b)
        integer :: a, b
        add_integer = a + b
    end function add_integer

    real function add_real(a, b)
        real :: a, b
        add_real = a + b
    end function add_real
end module modu

program prog
    use modu

    interface add
        module procedure add_integer, add_real
    end interface add

    integer :: i1, i2, ia
    real :: r1, r2, ra
    complex :: c
    i1 = 1
    i2 = 2
    r1 = 1.0
    r2 = 2.0
    c = (5.0, 3.0)

    ia = add(i1, i2)
    ra = add(r1, r2)
    c = add(c, r2)
    print *, ia, ra
end program prog


! { dg-do compile }
! { dg-options "-floop-nest-optimize -O1" }

MODULE d3_poly
    INTEGER, PUBLIC, PARAMETER :: max_grad2=5
    INTEGER, PUBLIC, PARAMETER :: max_grad3=3
    INTEGER, PUBLIC, PARAMETER :: cached_dim2=(max_grad2+1)*(max_grad2+2)/2
    INTEGER, PUBLIC, PARAMETER :: cached_dim3=(max_grad3+1)*(max_grad3+2)*(max_grad3+3)/6
    INTEGER, SAVE, DIMENSION(3,cached_dim3) :: a_mono_exp3
    INTEGER, SAVE, DIMENSION(cached_dim2,cached_dim2) :: a_mono_mult2
    INTEGER, SAVE, DIMENSION(cached_dim3,cached_dim3) :: a_mono_mult3
    INTEGER, SAVE, DIMENSION(4,cached_dim3) :: a_mono_mult3a
CONTAINS
SUBROUTINE init_d3_poly_module()
    INTEGER                                  :: grad, i, ii, ij, j, subG
    INTEGER, DIMENSION(3)                    :: monoRes3
    DO grad=0,max_grad2
        DO i=grad,0,-1
            DO j=grad-i,0,-1
            END DO
        END DO
    END DO
    DO ii=1,cached_dim3
        DO ij=ii,cached_dim2
            a_mono_mult2(ij,ii)=a_mono_mult2(ii,ij)
        END DO
    END DO
    DO ii=1,cached_dim3
        DO ij=ii,cached_dim3
            monoRes3=a_mono_exp3(:,ii)+a_mono_exp3(:,ij)
            a_mono_mult3(ii,ij)=mono_index3(monoRes3(1),monoRes3(2),monoRes3(3))+1
            a_mono_mult3(ij,ii)=a_mono_mult3(ii,ij)
        END DO
    END DO
    DO i=1,cached_dim3
       DO j=1,4
          a_mono_mult3a(j,i)=a_mono_mult3(j,i)
       END DO
    END DO
END SUBROUTINE
PURE FUNCTION mono_index3(i,j,k) RESULT(res)
    INTEGER, INTENT(in)                      :: i, j, k
    res=grad*(grad+1)*(grad+2)/6+(sgrad)*(sgrad+1)/2+k
END FUNCTION
END MODULE d3_poly


submodule (m_Sort) sm_MergeSort
  !! Merge sort and arg Merge sort routines
use m_errors, only: mErr

contains
!====================================================================!
module procedure mergeSort_d1D
  !! Interfaced with mergeSort()
!====================================================================!
!module subroutine mergeSort_d1D
!real(r64) :: this(:)
real(r64),allocatable :: aux(:)
integer(i32) :: iLeft,iRight
iLeft=1;iRight=size(this)
allocate(aux(iRight),stat=istat);call mErr(istat,'MergeSort:Auxiliary Array',1)
aux=0.d0
call SplitSort_d1D(this,aux,iLeft,iRight)
deallocate(aux)
end procedure
!====================================================================!
!====================================================================!
recursive subroutine SplitSort_d1D(this,aux,iLeft,iRight)
!====================================================================!
real(r64) :: this(:)
real(r64) :: aux(:)
integer(i32) :: iLeft,iRight
integer(i32) :: iMid
if (iRight <= iLeft) return
if (iRight <= iLeft + 19) then
  call InsertionSort(this,iLeft,iRight)
  return
end if
iMid=iLeft+(iRight-iLeft)/2
call SplitSort_d1D(this,aux,iLeft,iMid)
call SplitSort_d1D(this,aux,iMid+1,iRight)
call MergeSorted_d1D(this,aux,iLeft,iMid,iRight)
end subroutine
!====================================================================!
!====================================================================!
subroutine MergeSorted_d1D(this,aux,iLeft,iMid,iRight)
!====================================================================!
real(r64) :: this(:)
real(r64) :: aux(:)
integer(i32) :: iLeft,iMid,iRight
integer(i32) :: i,j,k

aux(iLeft:iRight)=this(iLeft:iRight)
i=iLeft;j=iMid+1
do k=iLeft,iRight
  if (i > iMid) then
    this(k)=aux(j);j=j+1
  elseif (j > iRight) then
    this(k)=aux(i);i=i+1
  elseif (aux(j) < aux(i)) then
    this(k)=aux(j);j=j+1
  else
    this(k)=aux(i);i=i+1
  end if
enddo
end subroutine
!====================================================================!
!====================================================================!
module procedure mergeSort_r1D
  !! Interfaced with mergeSort()
!====================================================================!
!module subroutine mergeSort_r1D
!real(r32) :: this(:)
real(r32),allocatable :: aux(:)
integer(i32) :: iLeft,iRight
iLeft=1;iRight=size(this)
allocate(aux(iRight),stat=istat);call Merr(istat,'MergeSort:Auxiliary Array',1)
aux=0.d0
call SplitSort_r1D(this,aux,iLeft,iRight)
deallocate(aux)
end procedure
!====================================================================!
!====================================================================!
recursive subroutine SplitSort_r1D(this,aux,iLeft,iRight)
!====================================================================!
real(r32) :: this(:)
real(r32) :: aux(:)
integer(i32) :: iLeft,iRight
integer(i32) :: iMid
if (iRight <= iLeft) return
if (iRight <= iLeft + 19) then
  call InsertionSort(this,iLeft,iRight)
  return
end if
iMid=iLeft+(iRight-iLeft)/2
call SplitSort_r1D(this,aux,iLeft,iMid)
call SplitSort_r1D(this,aux,iMid+1,iRight)
call MergeSorted_r1D(this,aux,iLeft,iMid,iRight)
end subroutine
!====================================================================!
!====================================================================!
subroutine MergeSorted_r1D(this,aux,iLeft,iMid,iRight)
!====================================================================!
real(r32) :: this(:)
real(r32) :: aux(:)
integer(i32) :: iLeft,iMid,iRight
integer(i32) :: i,j,k

aux(iLeft:iRight)=this(iLeft:iRight)
i=iLeft;j=iMid+1
do k=iLeft,iRight
  if (i > iMid) then
    this(k)=aux(j);j=j+1
  elseif (j > iRight) then
    this(k)=aux(i);i=i+1
  elseif (aux(j) < aux(i)) then
    this(k)=aux(j);j=j+1
  else
    this(k)=aux(i);i=i+1
  end if
enddo
end subroutine
!====================================================================!
!====================================================================!
module procedure MergeSort_i1D
  !! Interfaced with mergeSort()
!====================================================================!
!module subroutine mergeSort_i1D
!integer(i32) :: this(:)
integer(i32),allocatable :: aux(:)
integer(i32) :: iLeft,iRight
iLeft=1;iRight=size(this)
allocate(aux(iRight),stat=istat);call Merr(istat,'MergeSort:Auxiliary Array',1)
aux=0
call SplitSort_i1D(this,aux,iLeft,iRight)
deallocate(aux)
end procedure
!====================================================================!
!====================================================================!
recursive subroutine SplitSort_i1D(this,aux,iLeft,iRight)
!====================================================================!
integer(i32) :: this(:)
integer(i32) :: aux(:)
integer(i32) :: iLeft,iRight
integer(i32) :: iMid
if (iRight <= iLeft) return
if (iRight <= iLeft + 32) then
  call InsertionSort(this,iLeft,iRight)
  return
end if
iMid=iLeft+(iRight-iLeft)/2
call SplitSort_i1D(this,aux,iLeft,iMid)
call SplitSort_i1D(this,aux,iMid+1,iRight)
call MergeSorted_i1D(this,aux,iLeft,iMid,iRight)
end subroutine
!====================================================================!
!====================================================================!
subroutine MergeSorted_i1D(this,aux,iLeft,iMid,iRight)
!====================================================================!
integer(i32) :: this(:)
integer(i32) :: aux(:)
integer(i32) :: iLeft,iMid,iRight
integer(i32) :: i,j,k

do k=iLeft,iRight
  aux(k)=this(k)
end do
i=iLeft;j=iMid+1
do k=iLeft,iRight
  if (i > iMid) then
    this(k)=aux(j);j=j+1
  elseif (j > iRight) then
    this(k)=aux(i);i=i+1
  elseif (aux(j) < aux(i)) then
    this(k)=aux(j);j=j+1
  else
    this(k)=aux(i);i=i+1
  end if
enddo
end subroutine
!====================================================================!
!====================================================================!
module procedure MergeSort_id1D
  !! Interfaced with mergeSort()
!====================================================================!
!module subroutine mergeSort_id1D
!integer(i64) :: this(:)
integer(i64),allocatable :: aux(:)
integer(i32) :: iLeft,iRight
iLeft=1;iRight=size(this)
allocate(aux(iRight),stat=istat);call Merr(istat,'MergeSort:Auxiliary Array',1)
aux=0
call SplitSort_id1D(this,aux,iLeft,iRight)
deallocate(aux)
end procedure
!====================================================================!
!====================================================================!
recursive subroutine SplitSort_id1D(this,aux,iLeft,iRight)
!====================================================================!
integer(i64) :: this(:)
integer(i64) :: aux(:)
integer(i32) :: iLeft,iRight
integer(i32) :: iMid
if (iRight <= iLeft) return
if (iRight <= iLeft + 32) then
  call InsertionSort(this,iLeft,iRight)
  return
end if
iMid=iLeft+(iRight-iLeft)/2
call SplitSort_id1D(this,aux,iLeft,iMid)
call SplitSort_id1D(this,aux,iMid+1,iRight)
call MergeSorted_id1D(this,aux,iLeft,iMid,iRight)
end subroutine
!====================================================================!
!====================================================================!
subroutine MergeSorted_id1D(this,aux,iLeft,iMid,iRight)
!====================================================================!
integer(i64) :: this(:)
integer(i64) :: aux(:)
integer(i32) :: iLeft,iMid,iRight
integer(i32) :: i,j,k

do k=iLeft,iRight
  aux(k)=this(k)
end do
i=iLeft;j=iMid+1
do k=iLeft,iRight
  if (i > iMid) then
    this(k)=aux(j);j=j+1
  elseif (j > iRight) then
    this(k)=aux(i);i=i+1
  elseif (aux(j) < aux(i)) then
    this(k)=aux(j);j=j+1
  else
    this(k)=aux(i);i=i+1
  end if
enddo
end subroutine
!====================================================================!
!====================================================================!
module procedure argMergeSort_d1D
  !! Interfaced with argMergeSort()
!====================================================================!
!module subroutine argMergeSort_d1D
!real(r64) :: this(:)
!integer(i32) :: i(:)
integer(i32),allocatable :: aux(:)
integer(i32) :: iLeft,iRight
iLeft=1;iRight=size(this)
allocate(aux(iRight),stat=istat);call Merr(istat,'MergeSort:Auxiliary Array',1)
aux=0
call argSplitSort_d1D(this,i,aux,iLeft,iRight)
deallocate(aux)
end procedure
!====================================================================!
!====================================================================!
recursive subroutine argSplitSort_d1D(this,indx,aux,iLeft,iRight)
!====================================================================!
real(r64) :: this(:)
integer(i32) :: indx(:)
integer(i32) :: aux(:)
integer(i32) :: iLeft,iRight
integer(i32) :: iMid
if (iRight <= iLeft) return
if (iRight <= iLeft + 32) then
  call argInsertionSort(this,indx,iLeft,iRight)
  return
end if
iMid=iLeft+(iRight-iLeft)/2
call argSplitSort_d1D(this,indx,aux,iLeft,iMid)
call argSplitSort_d1D(this,indx,aux,iMid+1,iRight)
call argMergeSorted_d1D(this,indx,aux,iLeft,iMid,iRight)
end subroutine
!====================================================================!
!====================================================================!
subroutine argMergeSorted_d1D(this,indx,aux,iLeft,iMid,iRight)
!====================================================================!
real(r64) :: this(:)
integer(i32) :: indx(:)
integer(i32) :: aux(:)
integer(i32) :: iLeft,iMid,iRight
integer(i32) :: i,j,k

aux(iLeft:iRight)=indx(iLeft:iRight)
i=iLeft;j=iMid+1
do k=iLeft,iRight
  if (i > iMid) then
    indx(k)=aux(j);j=j+1
  elseif (j > iRight) then
    indx(k)=aux(i);i=i+1
  elseif (this(aux(j)) < this(aux(i))) then
    indx(k)=aux(j);j=j+1
  else
    indx(k)=aux(i);i=i+1
  end if
enddo
end subroutine
!====================================================================!
!====================================================================!
module procedure argMergeSort_r1D
  !! Interfaced with argMergeSort()
!====================================================================!
!module subroutine argMergeSort_r1D
!real(r32) :: this(:)
!integer(i32) :: i(:)
integer(i32),allocatable :: aux(:)
integer(i32) :: iLeft,iRight
iLeft=1;iRight=size(this)
allocate(aux(iRight),stat=istat);call Merr(istat,'MergeSort:Auxiliary Array',1)
aux=0
call argSplitSort_r1D(this,i,aux,iLeft,iRight)
deallocate(aux)
end procedure
!====================================================================!
!====================================================================!
recursive subroutine argSplitSort_r1D(this,indx,aux,iLeft,iRight)
!====================================================================!
real(r32) :: this(:)
integer(i32) :: indx(:)
integer(i32) :: aux(:)
integer(i32) :: iLeft,iRight
integer(i32) :: iMid
if (iRight <= iLeft) return
if (iRight <= iLeft + 32) then
  call argInsertionSort(this,indx,iLeft,iRight)
  return
end if
iMid=iLeft+(iRight-iLeft)/2
call argSplitSort_r1D(this,indx,aux,iLeft,iMid)
call argSplitSort_r1D(this,indx,aux,iMid+1,iRight)
call argMergeSorted_r1D(this,indx,aux,iLeft,iMid,iRight)
end subroutine
!====================================================================!
!====================================================================!
subroutine argMergeSorted_r1D(this,indx,aux,iLeft,iMid,iRight)
!====================================================================!
real(r32) :: this(:)
integer(i32) :: indx(:)
integer(i32) :: aux(:)
integer(i32) :: iLeft,iMid,iRight
integer(i32) :: i,j,k

aux(iLeft:iRight)=indx(iLeft:iRight)
i=iLeft;j=iMid+1
do k=iLeft,iRight
  if (i > iMid) then
    indx(k)=aux(j);j=j+1
  elseif (j > iRight) then
    indx(k)=aux(i);i=i+1
  elseif (this(aux(j)) < this(aux(i))) then
    indx(k)=aux(j);j=j+1
  else
    indx(k)=aux(i);i=i+1
  end if
enddo
end subroutine
!====================================================================!
!====================================================================!
module procedure argMergeSort_i1D
  !! Interfaced with argMergeSort()
!====================================================================!
!module subroutine argMergeSort_i1D
!integer(i32) :: this(:)
!integer(i32) :: i(:)
integer(i32),allocatable :: aux(:)
integer(i32) :: iLeft,iRight
iLeft=1;iRight=size(this)
allocate(aux(iRight),stat=istat);call Merr(istat,'MergeSort:Auxiliary Array',1)
aux=0
call argSplitSort_i1D(this,i,aux,iLeft,iRight)
deallocate(aux)
end procedure
!====================================================================!
!====================================================================!
recursive subroutine argSplitSort_i1D(this,indx,aux,iLeft,iRight)
!====================================================================!
integer(i32) :: this(:)
integer(i32) :: indx(:)
integer(i32) :: aux(:)
integer(i32) :: iLeft,iRight
integer(i32) :: iMid
if (iRight <= iLeft) return
if (iRight <= iLeft + 19) then
  call argInsertionSort(this,indx,iLeft,iRight)
  return
end if
iMid=iLeft+(iRight-iLeft)/2
call argSplitSort_i1D(this,indx,aux,iLeft,iMid)
call argSplitSort_i1D(this,indx,aux,iMid+1,iRight)
call argMergeSorted_i1D(this,indx,aux,iLeft,iMid,iRight)
end subroutine
!====================================================================!
!====================================================================!
subroutine argMergeSorted_i1D(this,indx,aux,iLeft,iMid,iRight)
!====================================================================!
integer(i32) :: this(:)
integer(i32) :: indx(:)
integer(i32) :: aux(:)
integer(i32) :: iLeft,iMid,iRight
integer(i32) :: i,j,k

aux(iLeft:iRight)=indx(iLeft:iRight)
i=iLeft;j=iMid+1
do k=iLeft,iRight
  if (i > iMid) then
    indx(k)=aux(j);j=j+1
  elseif (j > iRight) then
    indx(k)=aux(i);i=i+1
  elseif (this(aux(j)) < this(aux(i))) then
    indx(k)=aux(j);j=j+1
  else
    indx(k)=aux(i);i=i+1
  end if
enddo
end subroutine
!====================================================================!
!====================================================================!
module procedure argMergeSort_id1D
  !! Interfaced with argMergeSort()
!====================================================================!
!module subroutine argMergeSort_i1D
!integer(i64) :: this(:)
!integer(i32) :: i(:)
integer(i32),allocatable :: aux(:)
integer(i32) :: iLeft,iRight
iLeft=1;iRight=size(this)
allocate(aux(iRight),stat=istat);call Merr(istat,'MergeSort:Auxiliary Array',1)
aux=0
call argSplitSort_id1D(this,i,aux,iLeft,iRight)
deallocate(aux)
end procedure
!====================================================================!
!====================================================================!
recursive subroutine argSplitSort_id1D(this,indx,aux,iLeft,iRight)
!====================================================================!
integer(i64) :: this(:)
integer(i32) :: indx(:)
integer(i32) :: aux(:)
integer(i32) :: iLeft,iRight
integer(i32) :: iMid
if (iRight <= iLeft) return
if (iRight <= iLeft + 19) then
  call argInsertionSort(this,indx,iLeft,iRight)
  return
end if
iMid=iLeft+(iRight-iLeft)/2
call argSplitSort_id1D(this,indx,aux,iLeft,iMid)
call argSplitSort_id1D(this,indx,aux,iMid+1,iRight)
call argMergeSorted_id1D(this,indx,aux,iLeft,iMid,iRight)
end subroutine
!====================================================================!
!====================================================================!
subroutine argMergeSorted_id1D(this,indx,aux,iLeft,iMid,iRight)
!====================================================================!
integer(i64) :: this(:)
integer(i32) :: indx(:)
integer(i32) :: aux(:)
integer(i32) :: iLeft,iMid,iRight
integer(i32) :: i,j,k

aux(iLeft:iRight)=indx(iLeft:iRight)
i=iLeft;j=iMid+1
do k=iLeft,iRight
  if (i > iMid) then
    indx(k)=aux(j);j=j+1
  elseif (j > iRight) then
    indx(k)=aux(i);i=i+1
  elseif (this(aux(j)) < this(aux(i))) then
    indx(k)=aux(j);j=j+1
  else
    indx(k)=aux(i);i=i+1
  end if
enddo
end subroutine
!====================================================================!
end submodule


!>
!! @file
!!
!!  PLASMA is a software package provided by:
!!  University of Tennessee,  US,
!!  University of Manchester, UK
!!
!! @precisions mixed zc -> ds
!!
!! @brief Tests LU factorization-based iterative refinement routine for
!!  solution of linear system A*X=B, where A is n-by-n matrix, X and B
!!  are n-by-nrhs matrices

      program test_zcgesv

      use, intrinsic :: iso_fortran_env
      use            :: iso_c_binding
      use            :: omp_lib
      use            :: plasma

      implicit none

      ! Precisions
      integer, parameter :: sp = c_float
      integer, parameter :: dp = c_double

      ! Matrices A, X, B
      complex(dp), allocatable :: A(:,:), Aref(:,:), X(:,:), B(:,:)

      ! Matrix dimensions
      integer :: n = 1000, nrhs = 1, lda, ldb, ldx

      ! PLASMA variables
      integer :: nb = 120
      integer :: iter, info

      ! LAPACK variables
      integer :: iSeed(8) = [218, 1910, 3542, 2995, 3607, 27, 3488, 593]

      complex(dp) :: zone = 1.0, zmone = -1.0

      real(dp), allocatable :: work(:)
      real(dp)              :: Anorm, Xnorm, Rnorm, relerr

      ! Pivots
      integer, allocatable :: iPiv(:)

      ! Test variables
      real(dp)          :: tol  = 0.0d+0

      ! Performance variables
      real(dp) :: tstart = 0.0d+0, tstop = 0.0d+0, telapsed = 0.0d+0

      ! External functions
      real(dp), external :: dlamch
      real(dp), external :: zlange

      lda = max(1,n)
      ldb = lda
      ldx = lda

      tol = 50.0d+0 * dlamch('E')

      ! Allocate matrices
      allocate(A(lda,n), Aref(lda,n), X(ldx,nrhs), B(ldb,nrhs), &
               iPiv(lda), work(n))

      !=================================================================
      ! Generate and initialize random matrices A and B
      !=================================================================

      ! Generate random matrices A, B
      call zlarnv(1, iSeed(1:4), lda*n, A)

      ! Save initial matrix A into Aref
      Aref = A

      ! Generate random matrix B
      call zlarnv(1, iSeed(5:8), ldb*nrhs, B)

      ! Initialize solution matrix X
      X = 0.0d+0

      !=================================================================
      ! Initialize PLASMA
      !=================================================================
      call plasma_init(info)

      call plasma_set(PlasmaNb, nb, info)

      !=================================================================
      ! Solve linear system A*X=B
      !=================================================================
      tstart   = omp_get_wtime()

      call plasma_zcgesv(n, nrhs, A, lda, iPiv, B, ldb, X, ldx, &
                         iter, info)

      tstop    = omp_get_wtime()
      telapsed = tstop - tstart

      !=================================================================
      ! Finalize PLASMA
      !=================================================================
      call plasma_finalize(info)

      !=================================================================
      ! Perform linear system A*X=B solution check
      !=================================================================

      ! Calculate infinite norms of matrices Aref and X
      Anorm = zlange('I', n, n,    Aref, lda, work)
      Xnorm = zlange('I', n, nrhs, X,    ldx, work)

      ! Calculate residual R = A*X-B, store result in B
      call zgemm('N', 'N', n, nrhs, n, zone, Aref, lda, X, ldx, &
                  zmone, B, ldb)

      ! Calculate infinite norm of residual matrix R
      Rnorm = zlange('I', n, nrhs, B, ldb, work)

      ! Calculate relative error
      relerr = Rnorm / n / Anorm / Xnorm

      print *, "Time:            ", telapsed
      print *, "Iter. to solve:  ", iter
      print *, "Tolerance:       ", tol
      print *, "Relative error:  ", relerr

      if (relerr < tol) then
        print *, "Solution: CORRECT"
      else
        print *, "Solution: WRONG"
      end if
      write(*,'(a)') ""

      ! Deallocate matrices
      deallocate(A, Aref, X, B, iPiv, work, stat=info)

      end program test_zcgesv


      SUBROUTINE slPLNT (DATE, NP, PV, JSTAT)
*+
*     - - - - - - -
*      P L N T
*     - - - - - - -
*
*  Approximate heliocentric position and velocity of a specified
*  major planet.
*
*  Given:
*     DATE      d      Modified Julian Date (JD - 2400000.5)
*     NP        i      planet (1=Mercury, 2=Venus, 3=EMB ... 9=Pluto)
*
*  Returned:
*     PV        d(6)   heliocentric x,y,z,xdot,ydot,zdot, J2000
*                                           equatorial triad (AU,AU/s)
*     JSTAT     i      status: +1 = warning: date out of range
*                               0 = OK
*                              -1 = illegal NP (outside 1-9)
*                              -2 = solution didn't converge
*
*  Called:  slPLNE
*
*  Notes
*
*  1  The epoch, DATE, is in the TDB timescale and is a Modified
*     Julian Date (JD-2400000.5).
*
*  2  The reference frame is equatorial and is with respect to the
*     mean equinox and ecliptic of epoch J2000.
*
*  3  If an NP value outside the range 1-9 is supplied, an error
*     status (JSTAT = -1) is returned and the PV vector set to zeroes.
*
*  4  The algorithm for obtaining the mean elements of the planets
*     from Mercury to Neptune is due to J.L. Simon, P. Bretagnon,
*     J. Chapront, M. Chapront-Touze, G. Francou and J. Laskar
*     (Bureau des Longitudes, Paris).  The (completely different)
*     algorithm for calculating the ecliptic coordinates of Pluto
*     is by Meeus.
*
*  5  Comparisons of the present routine with the JPL DE200 ephemeris
*     give the following RMS errors over the interval 1960-2025:
*
*                      position (km)     speed (metre/sec)
*
*        Mercury            334               0.437
*        Venus             1060               0.855
*        EMB               2010               0.815
*        Mars              7690               1.98
*        Jupiter          71700               7.70
*        Saturn          199000              19.4
*        Uranus          564000              16.4
*        Neptune         158000              14.4
*        Pluto            36400               0.137
*
*     From comparisons with DE102, Simon et al quote the following
*     longitude accuracies over the interval 1800-2200:
*
*        Mercury                 4"
*        Venus                   5"
*        EMB                     6"
*        Mars                   17"
*        Jupiter                71"
*        Saturn                 81"
*        Uranus                 86"
*        Neptune                11"
*
*     In the case of Pluto, Meeus quotes an accuracy of 0.6 arcsec
*     in longitude and 0.2 arcsec in latitude for the period
*     1885-2099.
*
*     For all except Pluto, over the period 1000-3000 the accuracy
*     is better than 1.5 times that over 1800-2200.  Outside the
*     period 1000-3000 the accuracy declines.  For Pluto the
*     accuracy declines rapidly outside the period 1885-2099.
*     Outside these ranges (1885-2099 for Pluto, 1000-3000 for
*     the rest) a "date out of range" warning status (JSTAT=+1)
*     is returned.
*
*  6  The algorithms for (i) Mercury through Neptune and (ii) Pluto
*     are completely independent.  In the Mercury through Neptune
*     case, the present SLALIB implementation differs from the
*     original Simon et al Fortran code in the following respects.
*
*     *  The date is supplied as a Modified Julian Date rather
*        than a Julian Date (MJD = JD - 2400000.5).
*
*     *  The result is returned only in equatorial Cartesian form;
*        the ecliptic longitude, latitude and radius vector are not
*        returned.
*
*     *  The velocity is in AU per second, not AU per day.
*
*     *  Different error/warning status values are used.
*
*     *  Kepler's equation is not solved inline.
*
*     *  Polynomials in T are nested to minimize rounding errors.
*
*     *  Explicit double-precision constants are used to avoid
*        mixed-mode expressions.
*
*     *  There are other, cosmetic, changes to comply with
*        Starlink/SLALIB style guidelines.
*
*     None of the above changes affects the result significantly.
*
*  7  For NP=3 the result is for the Earth-Moon Barycentre.  To
*     obtain the heliocentric position and velocity of the Earth,
*     either use the SLALIB routine slEVP (or slEPV) or call
*     slDMON and subtract 0.012150581 times the geocentric Moon
*     vector from the EMB vector produced by the present routine.
*     (The Moon vector should be precessed to J2000 first, but this
*     can be omitted for modern epochs without introducing significant
*     inaccuracy.)
*
*  References:  Simon et al., Astron. Astrophys. 282, 663 (1994).
*               Meeus, Astronomical Algorithms, Willmann-Bell (1991).
*
*  This revision:  19 June 2004
*
*  Copyright (C) 2004 P.T.Wallace.  All rights reserved.
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      DOUBLE PRECISION DATE
      INTEGER NP
      DOUBLE PRECISION PV(6)
      INTEGER JSTAT

*  2Pi, deg to radians, arcsec to radians
      DOUBLE PRECISION D2PI,D2R,AS2R
      PARAMETER (D2PI=6.283185307179586476925286766559D0,
     :           D2R=0.017453292519943295769236907684886D0,
     :           AS2R=4.848136811095359935899141023579D-6)

*  Gaussian gravitational constant (exact)
      DOUBLE PRECISION GCON
      PARAMETER (GCON=0.01720209895D0)

*  Seconds per Julian century
      DOUBLE PRECISION SPC
      PARAMETER (SPC=36525D0*86400D0)

*  Sin and cos of J2000 mean obliquity (IAU 1976)
      DOUBLE PRECISION SE,CE
      PARAMETER (SE=0.3977771559319137D0,
     :           CE=0.9174820620691818D0)

      INTEGER I,J,IJSP(3,43)
      DOUBLE PRECISION AMAS(8),A(3,8),DLM(3,8),E(3,8),
     :                 PI(3,8),DINC(3,8),OMEGA(3,8),
     :                 DKP(9,8),CA(9,8),SA(9,8),
     :                 DKQ(10,8),CLO(10,8),SLO(10,8),
     :                 T,DA,DE,DPE,DI,DO,DMU,ARGA,ARGL,DM,
     :                 AB(2,3,43),DJ0,DS0,DP0,DL0,DLD0,DB0,DR0,
     :                 DJ,DS,DP,DJD,DSD,DPD,WLBR(3),WLBRD(3),
     :                 WJ,WS,WP,AL,ALD,SAL,CAL,
     :                 AC,BC,DL,DLD,DB,DBD,DR,DRD,
     :                 SL,CL,SB,CB,SLCB,CLCB,X,Y,Z,XD,YD,ZD

*  -----------------------
*  Mercury through Neptune
*  -----------------------

*  Planetary inverse masses
      DATA AMAS / 6023600D0,408523.5D0,328900.5D0,3098710D0,
     :            1047.355D0,3498.5D0,22869D0,19314D0 /

*
*  Tables giving the mean Keplerian elements, limited to T**2 terms:
*
*         A       semi-major axis (AU)
*         DLM     mean longitude (degree and arcsecond)
*         E       eccentricity
*         PI      longitude of the perihelion (degree and arcsecond)
*         DINC    inclination (degree and arcsecond)
*         OMEGA   longitude of the ascending node (degree and arcsecond)
*
      DATA A /
     :  0.3870983098D0,             0D0,      0D0,
     :  0.7233298200D0,             0D0,      0D0,
     :  1.0000010178D0,             0D0,      0D0,
     :  1.5236793419D0,           3D-10,      0D0,
     :  5.2026032092D0,       19132D-10,  -39D-10,
     :  9.5549091915D0, -0.0000213896D0,  444D-10,
     : 19.2184460618D0,       -3716D-10,  979D-10,
     : 30.1103868694D0,      -16635D-10,  686D-10 /
*
      DATA DLM /
     : 252.25090552D0, 5381016286.88982D0,  -1.92789D0,
     : 181.97980085D0, 2106641364.33548D0,   0.59381D0,
     : 100.46645683D0, 1295977422.83429D0,  -2.04411D0,
     : 355.43299958D0,  689050774.93988D0,   0.94264D0,
     :  34.35151874D0,  109256603.77991D0, -30.60378D0,
     :  50.07744430D0,   43996098.55732D0,  75.61614D0,
     : 314.05500511D0,   15424811.93933D0,  -1.75083D0,
     : 304.34866548D0,    7865503.20744D0,   0.21103D0/
*
      DATA E /
     : 0.2056317526D0,  0.0002040653D0,      -28349D-10,
     : 0.0067719164D0, -0.0004776521D0,       98127D-10,
     : 0.0167086342D0, -0.0004203654D0, -0.0000126734D0,
     : 0.0934006477D0,  0.0009048438D0,      -80641D-10,
     : 0.0484979255D0,  0.0016322542D0, -0.0000471366D0,
     : 0.0555481426D0, -0.0034664062D0, -0.0000643639D0,
     : 0.0463812221D0, -0.0002729293D0,  0.0000078913D0,
     : 0.0094557470D0,  0.0000603263D0,            0D0 /
*
      DATA PI /
     :  77.45611904D0,  5719.11590D0,   -4.83016D0,
     : 131.56370300D0,   175.48640D0, -498.48184D0,
     : 102.93734808D0, 11612.35290D0,   53.27577D0,
     : 336.06023395D0, 15980.45908D0,  -62.32800D0,
     :  14.33120687D0,  7758.75163D0,  259.95938D0,
     :  93.05723748D0, 20395.49439D0,  190.25952D0,
     : 173.00529106D0,  3215.56238D0,  -34.09288D0,
     :  48.12027554D0,  1050.71912D0,   27.39717D0 /
*
      DATA DINC /
     : 7.00498625D0, -214.25629D0,   0.28977D0,
     : 3.39466189D0,  -30.84437D0, -11.67836D0,
     :          0D0,  469.97289D0,  -3.35053D0,
     : 1.84972648D0, -293.31722D0,  -8.11830D0,
     : 1.30326698D0,  -71.55890D0,  11.95297D0,
     : 2.48887878D0,   91.85195D0, -17.66225D0,
     : 0.77319689D0,  -60.72723D0,   1.25759D0,
     : 1.76995259D0,    8.12333D0,   0.08135D0 /
*
      DATA OMEGA /
     :  48.33089304D0,  -4515.21727D0,  -31.79892D0,
     :  76.67992019D0, -10008.48154D0,  -51.32614D0,
     : 174.87317577D0,  -8679.27034D0,   15.34191D0,
     :  49.55809321D0, -10620.90088D0, -230.57416D0,
     : 100.46440702D0,   6362.03561D0,  326.52178D0,
     : 113.66550252D0,  -9240.19942D0,  -66.23743D0,
     :  74.00595701D0,   2669.15033D0,  145.93964D0,
     : 131.78405702D0,   -221.94322D0,   -0.78728D0 /
*
*  Tables for trigonometric terms to be added to the mean elements
*  of the semi-major axes.
*
      DATA DKP /
     : 69613, 75645, 88306, 59899, 15746, 71087, 142173,  3086,    0,
     : 21863, 32794, 26934, 10931, 26250, 43725,  53867, 28939,    0,
     : 16002, 21863, 32004, 10931, 14529, 16368,  15318, 32794,    0,
     : 6345,   7818, 15636,  7077,  8184, 14163,   1107,  4872,    0,
     : 1760,   1454,  1167,   880,   287,  2640,     19,  2047, 1454,
     :  574,      0,   880,   287,    19,  1760,   1167,   306,  574,
     :  204,      0,   177,  1265,     4,   385,    200,   208,  204,
     :    0,    102,   106,     4,    98,  1367,    487,   204,    0 /
*
      DATA CA /
     :      4,    -13,    11,    -9,    -9,    -3,    -1,     4,    0,
     :   -156,     59,   -42,     6,    19,   -20,   -10,   -12,    0,
     :     64,   -152,    62,    -8,    32,   -41,    19,   -11,    0,
     :    124,    621,  -145,   208,    54,   -57,    30,    15,    0,
     : -23437,  -2634,  6601,  6259, -1507, -1821,  2620, -2115,-1489,
     :  62911,-119919, 79336, 17814,-24241, 12068,  8306, -4893, 8902,
     : 389061,-262125,-44088,  8387,-22976, -2093,  -615, -9720, 6633,
     :-412235,-157046,-31430, 37817, -9740,   -13, -7449,  9644,    0 /
*
      DATA SA /
     :     -29,    -1,     9,     6,    -6,     5,     4,     0,    0,
     :     -48,  -125,   -26,   -37,    18,   -13,   -20,    -2,    0,
     :    -150,   -46,    68,    54,    14,    24,   -28,    22,    0,
     :    -621,   532,  -694,   -20,   192,   -94,    71,   -73,    0,
     :  -14614,-19828, -5869,  1881, -4372, -2255,   782,   930,  913,
     :  139737,     0, 24667, 51123, -5102,  7429, -4095, -1976,-9566,
     : -138081,     0, 37205,-49039,-41901,-33872,-27037,-12474,18797,
     :       0, 28492,133236, 69654, 52322,-49577,-26430, -3593,    0 /
*
*  Tables giving the trigonometric terms to be added to the mean
*  elements of the mean longitudes.
*
      DATA DKQ /
     :  3086, 15746, 69613, 59899, 75645, 88306, 12661, 2658,  0,   0,
     : 21863, 32794, 10931,    73,  4387, 26934,  1473, 2157,  0,   0,
     :    10, 16002, 21863, 10931,  1473, 32004,  4387,   73,  0,   0,
     :    10,  6345,  7818,  1107, 15636,  7077,  8184,  532, 10,   0,
     :    19,  1760,  1454,   287,  1167,   880,   574, 2640, 19,1454,
     :    19,   574,   287,   306,  1760,    12,    31,   38, 19, 574,
     :     4,   204,   177,     8,    31,   200,  1265,  102,  4, 204,
     :     4,   102,   106,     8,    98,  1367,   487,  204,  4, 102 /
*
      DATA CLO /
     :     21,   -95, -157,   41,   -5,   42,   23,   30,     0,    0,
     :   -160,  -313, -235,   60,  -74,  -76,  -27,   34,     0,    0,
     :   -325,  -322,  -79,  232,  -52,   97,   55,  -41,     0,    0,
     :   2268,  -979,  802,  602, -668,  -33,  345,  201,   -55,    0,
     :   7610, -4997,-7689,-5841,-2617, 1115, -748, -607,  6074,  354,
     : -18549, 30125,20012, -730,  824,   23, 1289, -352,-14767,-2062,
     :-135245,-14594, 4197,-4030,-5630,-2898, 2540, -306,  2939, 1986,
     :  89948,  2103, 8963, 2695, 3682, 1648,  866, -154, -1963, -283 /
*
      DATA SLO /
     :   -342,   136,  -23,   62,   66,  -52,  -33,   17,     0,    0,
     :    524,  -149,  -35,  117,  151,  122,  -71,  -62,     0,    0,
     :   -105,  -137,  258,   35, -116,  -88, -112,  -80,     0,    0,
     :    854,  -205, -936, -240,  140, -341,  -97, -232,   536,    0,
     : -56980,  8016, 1012, 1448,-3024,-3710,  318,  503,  3767,  577,
     : 138606,-13478,-4964, 1441,-1319,-1482,  427, 1236, -9167,-1918,
     :  71234,-41116, 5334,-4935,-1848,   66,  434,-1748,  3780, -701,
     : -47645, 11647, 2166, 3194,  679,    0, -244, -419, -2531,   48 /

*  -----
*  Pluto
*  -----

*
*  Coefficients for fundamental arguments:  mean longitudes
*  (degrees) and mean rate of change of longitude (degrees per
*  Julian century) for Jupiter, Saturn and Pluto
*
      DATA DJ0, DJD / 34.35D0, 3034.9057D0 /
      DATA DS0, DSD / 50.08D0, 1222.1138D0 /
      DATA DP0, DPD / 238.96D0, 144.9600D0 /

*  Coefficients for latitude, longitude, radius vector
      DATA DL0,DLD0 / 238.956785D0, 144.96D0 /
      DATA DB0 / -3.908202D0 /
      DATA DR0 / 40.7247248D0 /

*
*  Coefficients for periodic terms (Meeus's Table 36.A)
*
*  The coefficients for term n in the series are:
*
*    IJSP(1,n)     J
*    IJSP(2,n)     S
*    IJSP(3,n)     P
*    AB(1,1,n)     longitude sine (degrees)
*    AB(2,1,n)     longitude cosine (degrees)
*    AB(1,2,n)     latitude sine (degrees)
*    AB(2,2,n)     latitude cosine (degrees)
*    AB(1,3,n)     radius vector sine (AU)
*    AB(2,3,n)     radius vector cosine (AU)
*
      DATA (IJSP(I, 1),I=1,3),((AB(J,I, 1),J=1,2),I=1,3) /
     :                             0,  0,  1,
     :            -19798886D-6,  19848454D-6,
     :             -5453098D-6, -14974876D-6,
     :             66867334D-7,  68955876D-7 /
      DATA (IJSP(I, 2),I=1,3),((AB(J,I, 2),J=1,2),I=1,3) /
     :                             0,  0,  2,
     :               897499D-6,  -4955707D-6,
     :              3527363D-6,   1672673D-6,
     :            -11826086D-7,   -333765D-7 /
      DATA (IJSP(I, 3),I=1,3),((AB(J,I, 3),J=1,2),I=1,3) /
     :                             0,  0,  3,
     :               610820D-6,   1210521D-6,
     :             -1050939D-6,    327763D-6,
     :              1593657D-7,  -1439953D-7 /
      DATA (IJSP(I, 4),I=1,3),((AB(J,I, 4),J=1,2),I=1,3) /
     :                             0,  0,  4,
     :              -341639D-6,   -189719D-6,
     :               178691D-6,   -291925D-6,
     :               -18948D-7,    482443D-7 /
      DATA (IJSP(I, 5),I=1,3),((AB(J,I, 5),J=1,2),I=1,3) /
     :                             0,  0,  5,
     :               129027D-6,    -34863D-6,
     :                18763D-6,    100448D-6,
     :               -66634D-7,    -85576D-7 /
      DATA (IJSP(I, 6),I=1,3),((AB(J,I, 6),J=1,2),I=1,3) /
     :                             0,  0,  6,
     :               -38215D-6,     31061D-6,
     :               -30594D-6,    -25838D-6,
     :                30841D-7,     -5765D-7 /
      DATA (IJSP(I, 7),I=1,3),((AB(J,I, 7),J=1,2),I=1,3) /
     :                             0,  1, -1,
     :                20349D-6,     -9886D-6,
     :                 4965D-6,     11263D-6,
     :                -6140D-7,     22254D-7 /
      DATA (IJSP(I, 8),I=1,3),((AB(J,I, 8),J=1,2),I=1,3) /
     :                             0,  1,  0,
     :                -4045D-6,     -4904D-6,
     :                  310D-6,      -132D-6,
     :                 4434D-7,      4443D-7 /
      DATA (IJSP(I, 9),I=1,3),((AB(J,I, 9),J=1,2),I=1,3) /
     :                             0,  1,  1,
     :                -5885D-6,     -3238D-6,
     :                 2036D-6,      -947D-6,
     :                -1518D-7,       641D-7 /
      DATA (IJSP(I,10),I=1,3),((AB(J,I,10),J=1,2),I=1,3) /
     :                             0,  1,  2,
     :                -3812D-6,      3011D-6,
     :                   -2D-6,      -674D-6,
     :                   -5D-7,       792D-7 /
      DATA (IJSP(I,11),I=1,3),((AB(J,I,11),J=1,2),I=1,3) /
     :                             0,  1,  3,
     :                 -601D-6,      3468D-6,
     :                 -329D-6,      -563D-6,
     :                  518D-7,       518D-7 /
      DATA (IJSP(I,12),I=1,3),((AB(J,I,12),J=1,2),I=1,3) /
     :                             0,  2, -2,
     :                 1237D-6,       463D-6,
     :                  -64D-6,        39D-6,
     :                  -13D-7,      -221D-7 /
      DATA (IJSP(I,13),I=1,3),((AB(J,I,13),J=1,2),I=1,3) /
     :                             0,  2, -1,
     :                 1086D-6,      -911D-6,
     :                  -94D-6,       210D-6,
     :                  837D-7,      -494D-7 /
      DATA (IJSP(I,14),I=1,3),((AB(J,I,14),J=1,2),I=1,3) /
     :                             0,  2,  0,
     :                  595D-6,     -1229D-6,
     :                   -8D-6,      -160D-6,
     :                 -281D-7,       616D-7 /
      DATA (IJSP(I,15),I=1,3),((AB(J,I,15),J=1,2),I=1,3) /
     :                             1, -1,  0,
     :                 2484D-6,      -485D-6,
     :                 -177D-6,       259D-6,
     :                  260D-7,      -395D-7 /
      DATA (IJSP(I,16),I=1,3),((AB(J,I,16),J=1,2),I=1,3) /
     :                             1, -1,  1,
     :                  839D-6,     -1414D-6,
     :                   17D-6,       234D-6,
     :                 -191D-7,      -396D-7 /
      DATA (IJSP(I,17),I=1,3),((AB(J,I,17),J=1,2),I=1,3) /
     :                             1,  0, -3,
     :                 -964D-6,      1059D-6,
     :                  582D-6,      -285D-6,
     :                -3218D-7,       370D-7 /
      DATA (IJSP(I,18),I=1,3),((AB(J,I,18),J=1,2),I=1,3) /
     :                             1,  0, -2,
     :                -2303D-6,     -1038D-6,
     :                 -298D-6,       692D-6,
     :                 8019D-7,     -7869D-7 /
      DATA (IJSP(I,19),I=1,3),((AB(J,I,19),J=1,2),I=1,3) /
     :                             1,  0, -1,
     :                 7049D-6,       747D-6,
     :                  157D-6,       201D-6,
     :                  105D-7,     45637D-7 /
      DATA (IJSP(I,20),I=1,3),((AB(J,I,20),J=1,2),I=1,3) /
     :                             1,  0,  0,
     :                 1179D-6,      -358D-6,
     :                  304D-6,       825D-6,
     :                 8623D-7,      8444D-7 /
      DATA (IJSP(I,21),I=1,3),((AB(J,I,21),J=1,2),I=1,3) /
     :                             1,  0,  1,
     :                  393D-6,       -63D-6,
     :                 -124D-6,       -29D-6,
     :                 -896D-7,      -801D-7 /
      DATA (IJSP(I,22),I=1,3),((AB(J,I,22),J=1,2),I=1,3) /
     :                             1,  0,  2,
     :                  111D-6,      -268D-6,
     :                   15D-6,         8D-6,
     :                  208D-7,      -122D-7 /
      DATA (IJSP(I,23),I=1,3),((AB(J,I,23),J=1,2),I=1,3) /
     :                             1,  0,  3,
     :                  -52D-6,      -154D-6,
     :                    7D-6,        15D-6,
     :                 -133D-7,        65D-7 /
      DATA (IJSP(I,24),I=1,3),((AB(J,I,24),J=1,2),I=1,3) /
     :                             1,  0,  4,
     :                  -78D-6,       -30D-6,
     :                    2D-6,         2D-6,
     :                  -16D-7,         1D-7 /
      DATA (IJSP(I,25),I=1,3),((AB(J,I,25),J=1,2),I=1,3) /
     :                             1,  1, -3,
     :                  -34D-6,       -26D-6,
     :                    4D-6,         2D-6,
     :                  -22D-7,         7D-7 /
      DATA (IJSP(I,26),I=1,3),((AB(J,I,26),J=1,2),I=1,3) /
     :                             1,  1, -2,
     :                  -43D-6,         1D-6,
     :                    3D-6,         0D-6,
     :                   -8D-7,        16D-7 /
      DATA (IJSP(I,27),I=1,3),((AB(J,I,27),J=1,2),I=1,3) /
     :                             1,  1, -1,
     :                  -15D-6,        21D-6,
     :                    1D-6,        -1D-6,
     :                    2D-7,         9D-7 /
      DATA (IJSP(I,28),I=1,3),((AB(J,I,28),J=1,2),I=1,3) /
     :                             1,  1,  0,
     :                   -1D-6,        15D-6,
     :                    0D-6,        -2D-6,
     :                   12D-7,         5D-7 /
      DATA (IJSP(I,29),I=1,3),((AB(J,I,29),J=1,2),I=1,3) /
     :                             1,  1,  1,
     :                    4D-6,         7D-6,
     :                    1D-6,         0D-6,
     :                    1D-7,        -3D-7 /
      DATA (IJSP(I,30),I=1,3),((AB(J,I,30),J=1,2),I=1,3) /
     :                             1,  1,  3,
     :                    1D-6,         5D-6,
     :                    1D-6,        -1D-6,
     :                    1D-7,         0D-7 /
      DATA (IJSP(I,31),I=1,3),((AB(J,I,31),J=1,2),I=1,3) /
     :                             2,  0, -6,
     :                    8D-6,         3D-6,
     :                   -2D-6,        -3D-6,
     :                    9D-7,         5D-7 /
      DATA (IJSP(I,32),I=1,3),((AB(J,I,32),J=1,2),I=1,3) /
     :                             2,  0, -5,
     :                   -3D-6,         6D-6,
     :                    1D-6,         2D-6,
     :                    2D-7,        -1D-7 /
      DATA (IJSP(I,33),I=1,3),((AB(J,I,33),J=1,2),I=1,3) /
     :                             2,  0, -4,
     :                    6D-6,       -13D-6,
     :                   -8D-6,         2D-6,
     :                   14D-7,        10D-7 /
      DATA (IJSP(I,34),I=1,3),((AB(J,I,34),J=1,2),I=1,3) /
     :                             2,  0, -3,
     :                   10D-6,        22D-6,
     :                   10D-6,        -7D-6,
     :                  -65D-7,        12D-7 /
      DATA (IJSP(I,35),I=1,3),((AB(J,I,35),J=1,2),I=1,3) /
     :                             2,  0, -2,
     :                  -57D-6,       -32D-6,
     :                    0D-6,        21D-6,
     :                  126D-7,      -233D-7 /
      DATA (IJSP(I,36),I=1,3),((AB(J,I,36),J=1,2),I=1,3) /
     :                             2,  0, -1,
     :                  157D-6,       -46D-6,
     :                    8D-6,         5D-6,
     :                  270D-7,      1068D-7 /
      DATA (IJSP(I,37),I=1,3),((AB(J,I,37),J=1,2),I=1,3) /
     :                             2,  0,  0,
     :                   12D-6,       -18D-6,
     :                   13D-6,        16D-6,
     :                  254D-7,       155D-7 /
      DATA (IJSP(I,38),I=1,3),((AB(J,I,38),J=1,2),I=1,3) /
     :                             2,  0,  1,
     :                   -4D-6,         8D-6,
     :                   -2D-6,        -3D-6,
     :                  -26D-7,        -2D-7 /
      DATA (IJSP(I,39),I=1,3),((AB(J,I,39),J=1,2),I=1,3) /
     :                             2,  0,  2,
     :                   -5D-6,         0D-6,
     :                    0D-6,         0D-6,
     :                    7D-7,         0D-7 /
      DATA (IJSP(I,40),I=1,3),((AB(J,I,40),J=1,2),I=1,3) /
     :                             2,  0,  3,
     :                    3D-6,         4D-6,
     :                    0D-6,         1D-6,
     :                  -11D-7,         4D-7 /
      DATA (IJSP(I,41),I=1,3),((AB(J,I,41),J=1,2),I=1,3) /
     :                             3,  0, -2,
     :                   -1D-6,        -1D-6,
     :                    0D-6,         1D-6,
     :                    4D-7,       -14D-7 /
      DATA (IJSP(I,42),I=1,3),((AB(J,I,42),J=1,2),I=1,3) /
     :                             3,  0, -1,
     :                    6D-6,        -3D-6,
     :                    0D-6,         0D-6,
     :                   18D-7,        35D-7 /
      DATA (IJSP(I,43),I=1,3),((AB(J,I,43),J=1,2),I=1,3) /
     :                             3,  0,  0,
     :                   -1D-6,        -2D-6,
     :                    0D-6,         1D-6,
     :                   13D-7,         3D-7 /

*  Validate the planet number.
      IF (NP.LT.1.OR.NP.GT.9) THEN
         JSTAT=-1
         DO I=1,6
            PV(I)=0D0
         END DO
      ELSE

*     Separate algorithms for Pluto and the rest.
         IF (NP.NE.9) THEN

*        -----------------------
*        Mercury through Neptune
*        -----------------------

*        Time: Julian millennia since J2000.
            T=(DATE-51544.5D0)/365250D0

*        OK status unless remote epoch.
            IF (ABS(T).LE.1D0) THEN
               JSTAT=0
            ELSE
               JSTAT=1
            END IF

*        Compute the mean elements.
            DA=A(1,NP)+(A(2,NP)+A(3,NP)*T)*T
            DL=(3600D0*DLM(1,NP)+(DLM(2,NP)+DLM(3,NP)*T)*T)*AS2R
            DE=E(1,NP)+(E(2,NP)+E(3,NP)*T)*T
            DPE=MOD((3600D0*PI(1,NP)+(PI(2,NP)+PI(3,NP)*T)*T)*AS2R,D2PI)
            DI=(3600D0*DINC(1,NP)+(DINC(2,NP)+DINC(3,NP)*T)*T)*AS2R
            DO=MOD((3600D0*OMEGA(1,NP)
     :                        +(OMEGA(2,NP)+OMEGA(3,NP)*T)*T)*AS2R,D2PI)

*        Apply the trigonometric terms.
            DMU=0.35953620D0*T
            DO J=1,8
               ARGA=DKP(J,NP)*DMU
               ARGL=DKQ(J,NP)*DMU
               DA=DA+(CA(J,NP)*COS(ARGA)+SA(J,NP)*SIN(ARGA))*1D-7
               DL=DL+(CLO(J,NP)*COS(ARGL)+SLO(J,NP)*SIN(ARGL))*1D-7
            END DO
            ARGA=DKP(9,NP)*DMU
            DA=DA+T*(CA(9,NP)*COS(ARGA)+SA(9,NP)*SIN(ARGA))*1D-7
            DO J=9,10
               ARGL=DKQ(J,NP)*DMU
               DL=DL+T*(CLO(J,NP)*COS(ARGL)+SLO(J,NP)*SIN(ARGL))*1D-7
            END DO
            DL=MOD(DL,D2PI)

*        Daily motion.
            DM=GCON*SQRT((1D0+1D0/AMAS(NP))/(DA*DA*DA))

*        Make the prediction.
            CALL slPLNE(DATE,1,DATE,DI,DO,DPE,DA,DE,DL,DM,PV,J)
            IF (J.LT.0) JSTAT=-2

         ELSE

*        -----
*        Pluto
*        -----

*        Time: Julian centuries since J2000.
            T=(DATE-51544.5D0)/36525D0

*        OK status unless remote epoch.
            IF (T.GE.-1.15D0.AND.T.LE.1D0) THEN
               JSTAT=0
            ELSE
               JSTAT=1
            END IF

*        Fundamental arguments (radians).
            DJ=(DJ0+DJD*T)*D2R
            DS=(DS0+DSD*T)*D2R
            DP=(DP0+DPD*T)*D2R

*        Initialize coefficients and derivatives.
            DO I=1,3
               WLBR(I)=0D0
               WLBRD(I)=0D0
            END DO

*        Term by term through Meeus Table 36.A.
            DO J=1,43

*           Argument and derivative (radians, radians per century).
               WJ=DBLE(IJSP(1,J))
               WS=DBLE(IJSP(2,J))
               WP=DBLE(IJSP(3,J))
               AL=WJ*DJ+WS*DS+WP*DP
               ALD=(WJ*DJD+WS*DSD+WP*DPD)*D2R

*           Functions of argument.
               SAL=SIN(AL)
               CAL=COS(AL)

*           Periodic terms in longitude, latitude, radius vector.
               DO I=1,3

*              A and B coefficients (deg, AU).
                  AC=AB(1,I,J)
                  BC=AB(2,I,J)

*              Periodic terms (deg, AU, deg/Jc, AU/Jc).
                  WLBR(I)=WLBR(I)+AC*SAL+BC*CAL
                  WLBRD(I)=WLBRD(I)+(AC*CAL-BC*SAL)*ALD
               END DO
            END DO

*        Heliocentric longitude and derivative (radians, radians/sec).
            DL=(DL0+DLD0*T+WLBR(1))*D2R
            DLD=(DLD0+WLBRD(1))*D2R/SPC

*        Heliocentric latitude and derivative (radians, radians/sec).
            DB=(DB0+WLBR(2))*D2R
            DBD=WLBRD(2)*D2R/SPC

*        Heliocentric radius vector and derivative (AU, AU/sec).
            DR=DR0+WLBR(3)
            DRD=WLBRD(3)/SPC

*        Functions of latitude, longitude, radius vector.
            SL=SIN(DL)
            CL=COS(DL)
            SB=SIN(DB)
            CB=COS(DB)
            SLCB=SL*CB
            CLCB=CL*CB

*        Heliocentric vector and derivative, J2000 ecliptic and equinox.
            X=DR*CLCB
            Y=DR*SLCB
            Z=DR*SB
            XD=DRD*CLCB-DR*(CL*SB*DBD+SLCB*DLD)
            YD=DRD*SLCB+DR*(-SL*SB*DBD+CLCB*DLD)
            ZD=DRD*SB+DR*CB*DBD

*        Transform to J2000 equator and equinox.
            PV(1)=X
            PV(2)=Y*CE-Z*SE
            PV(3)=Y*SE+Z*CE
            PV(4)=XD
            PV(5)=YD*CE-ZD*SE
            PV(6)=YD*SE+ZD*CE
         END IF
      END IF

      END


!>  RK stepper
module pf_my_stepper
  use pf_mod_dtype
  use pf_mod_zndarray
  use pf_mod_rkstepper
  use pf_mod_fftpackage
  use pf_mod_solutions
  use pf_mod_zutils
  use pf_mod_fftops
  implicit none

  ! Define the derived stepper type
  type, extends(pf_ark_stepper_t) :: my_stepper_t
     integer ::     nx
     ! fft object and differentiaton matrices
     type(pf_fft_t), pointer :: fft_tool
     type(pf_fft_ops_t), pointer :: fft_ops
     complex(pfdp), allocatable :: tmp(:)                ! Temp space for feval
     complex(pfdp), pointer :: p_tmp(:)   ! a useful pointer

     !  Useful for making routines  generic by dimension
     class(pf_zndarray_t), pointer :: f_encap,rhs_encap,y_encap
     complex(pfdp),        pointer :: yvec(:), rhsvec(:), fvec(:)

   contains

     procedure :: f_eval       !  Computes the advection and diffusion terms
     procedure :: f_comp       !  Computes the advection and diffusion terms
     procedure :: initialize
     procedure :: initialize_tmp
     procedure :: destroy

  end type my_stepper_t

contains
  subroutine initialize_tmp(this)
    class(my_stepper_t), intent(inout) :: this

    integer :: istat
    allocate(this%tmp(this%nx),STAT=istat)
    if (istat .ne. 0)  call pf_stop(__FILE__,__LINE__,'Allocate failed ',istat)

  end subroutine initialize_tmp

  ! The rest of the stuff is dimension independent
  include 'stepper_include.f90'

end module pf_my_stepper


program Equilibrium
  implicit none

  integer :: array(7) = (/ -7, 1, 5, 2, -4, 3, 0 /)

  call equil_index(array)

contains

subroutine equil_index(a)
  integer, intent(in) :: a(:)
  integer :: i

  do i = 1, size(a)
    if(sum(a(1:i-1)) == sum(a(i+1:size(a)))) write(*,*) i
  end do

end subroutine
end program


program i
  integer::a
  a=3 + 5 *  6 / 2 ** 2 ** 3
end program i


program get_proj_SSCorr
        implicit none
        integer :: i,j,l!,ntime
        integer,dimension(4900) :: para
        real*8, dimension(4900,4) :: corr_ss_proj
        real*8, dimension(4900,4) :: n_corr_ss_proj
        real*8, dimension(4900) :: dist,ndist
        real*8, dimension(4) :: avg
        integer*8, dimension(4900) :: ntime
        character*30 :: filein

        open(100,file='tmp',status='unknown')

        ntime=1
        j=1
        do i=1,4900
        read(100,*) dist(i),corr_ss_proj(i,1),corr_ss_proj(i,2),corr_ss_proj(i,3),corr_ss_proj(i,4)
        if (i .gt. 1) then
                if (dist(i) .gt. dist(i-1)) then
                        n_corr_ss_proj(j,1)=avg(1)
                        n_corr_ss_proj(j,2)=avg(2)
                        n_corr_ss_proj(j,3)=avg(3)
                        n_corr_ss_proj(j,4)=avg(4)

                        j=j+1
                        ndist(j)=dist(i)
                        ntime(j)=1

                        avg(1)=corr_ss_proj(i,1)
                        avg(2)=corr_ss_proj(i,2)
                        avg(3)=corr_ss_proj(i,3)
                        avg(4)=corr_ss_proj(i,4)
                        n_corr_ss_proj(j,1)=avg(1)
                        n_corr_ss_proj(j,2)=avg(2)
                        n_corr_ss_proj(j,3)=avg(3)
                        n_corr_ss_proj(j,4)=avg(4)

                else
                        j=j
                        ndist(j)=dist(i)

                        avg(1)=corr_ss_proj(i,1)+avg(1)
                        avg(2)=corr_ss_proj(i,2)+avg(2)
                        avg(3)=corr_ss_proj(i,3)+avg(3)
                        avg(4)=corr_ss_proj(i,4)+avg(4)

                        ntime(j)=ntime(j)+1
                endif
        endif
        n_corr_ss_proj(j,1)=avg(1)/ntime(j)
        write(112,'(3i5,5f10.5)') i,j,ntime(j),ndist(j),corr_ss_proj(i,1),avg(1),avg(1)/ntime(j),n_corr_ss_proj(j,1)
        write(114,'(2f10.5)') ndist(j),n_corr_ss_proj(j,1)
        enddo

        do i=1,j
        write(113,'(2f10.5,i2,f10.5)') ndist(i),n_corr_ss_proj(i,1),ntime(i),n_corr_ss_proj(i,1)/ntime(i)
        write(115,'(5f10.5)') ndist(i),(n_corr_ss_proj(i,j)/ntime(i),j=1,4)

        enddo

end program


PROGRAM Test_IFGtoSPC

  USE Type_Kinds           , ONLY: fp=>fp_kind
  USE Binary_File_Utility  , ONLY: Open_Binary_File
  USE Message_Handler      , ONLY: SUCCESS
  USE Fundamental_Constants, ONLY: PI
  USE FFT_Spectral_Utility , ONLY: IFGtoSPC
  IMPLICIT NONE
  ! Parameters
  CHARACTER(*), PARAMETER :: FILENAME='test_ifg.bin'
  ! Variables
  REAL(fp),    DIMENSION(:), ALLOCATABLE :: x
  REAL(fp),    DIMENSION(:), ALLOCATABLE :: rIfg, iIfg
  COMPLEX(fp), DIMENSION(:), ALLOCATABLE :: ifg
  REAL(fp),    DIMENSION(:), ALLOCATABLE :: f
  COMPLEX(fp), DIMENSION(:), ALLOCATABLE :: spc
  INTEGER :: fileId
  INTEGER :: n, n2
  INTEGER :: i, j, errStatus, ioStatus, allocStatus

  ! Read the interferometric data
  WRITE(*,'(/5x,"Reading input test interferogram...")' )
  errStatus = Open_Binary_File( FILENAME, &
                                fileId    )
  IF ( errStatus /= SUCCESS ) THEN
    WRITE(*,*) 'Error opening test interferogram file.'
    STOP
  END IF
  READ(fileId) n2  ! The number of IFG points
  n = (n2/2)+1     ! The number of SPC points
  ALLOCATE(rIfg(n2), iIfg(n2), x(n2), ifg(n2), f(n), spc(n), STAT=allocStatus)
  IF ( allocStatus /= 0 ) THEN
    WRITE(*,*) 'Error allocating arrays. STAT=',allocStatus
    STOP
  END IF
  READ(fileId)x     ! Optical delay data
  READ(fileId)rIfg  ! Real part of IFG
  READ(fileId)iIfg  ! Imaginary part of IFG
  CLOSE(fileId)

  ! Make the interferogram complex
  ifg = CMPLX(rIfg,iIfg,fp)

  ! Call the routine
  WRITE(*,'(5x,"Calling IFGtoSPC...")' )
  errStatus=IFGtoSPC(x, ifg, f, spc)
  IF ( errStatus /= SUCCESS ) THEN
    WRITE(*,*) 'Error in IFGtoSPC call'
    STOP
  END IF

  ! Output the IFG and SPC to a file
  WRITE(*,'(5x,"Writing output file......")' )
  errStatus = Open_Binary_File( 'Test_IFGtoSPC.bin', &
                                fileId, &
                                For_Output=1 )
  IF ( errStatus /= SUCCESS ) THEN
    WRITE(*,*) 'Error opening output results file.'
    STOP
  END IF
  ! The SPC data
  WRITE(fileId) n            ! The number of SPC points
  WRITE(fileId) f            ! Frequency data
  WRITE(fileId) REAL(spc,fp) ! Real part of SPC
  WRITE(fileId) AIMAG(spc)   ! Imaginary part of SPC
  ! The IFG data
  WRITE(fileId) n2           ! The number of IFG points
  WRITE(fileId) x            ! Optical delay data
  WRITE(fileId) rIfg         ! Real part of IFG
  WRITE(fileId) iIfg         ! Imaginary part of IFG
  CLOSE(fileId)

END PROGRAM Test_IFGtoSPC


module derivatives

implicit none
public
save

contains

subroutine zinteg(tmp,tint,n1,n2,mapping,per,rev)
    ! integrates a given field tmp in the vertical direction
    ! using trapezoidal rule (per=0) or Gauss quadrature (per=1)
    ! an adjustement is made for mappings with singularities
    use dim
    use grid
    use mpicom, only: myid
    ! input/output
    integer, intent(in) :: n1, n2, per, mapping, rev
    real, dimension(n1,n2,nzp), intent(inout) :: tmp
    real, dimension(n1,n2,nzp), intent(out) ::tint
    ! other vars
    integer :: i, m, j, k
    real :: wts(nzm),tj
    real :: integ, pi

    if (per==1) then
        ! compute integration weights
        pi=4.*atan(1.)
        do j=1,nzm
            tj=pi*float(j)/float(nz)
            wts(j)=0.0
            do m=1,nzm
                wts(j)=wts(j)+sin(float(m)*tj)*(1.0-cos(pi*float(m)))/float(m)
            end do
            wts(j)=2.00/float(nz)*sin(tj)*wts(j)
        end do
        ! integration with change of variable
        tint = 0.0
        do j=1,n2
            do i=1,n1
                integ=0.0
                do k=nz,2,-1
                    integ=integ+wts(k-1)*0.5*xl/gf(k)*tmp(i,j,k)
                    tint(i,j,k) = integ
                end do
                if (mapping==1) tint(i,j,1) = tint(i,j,2)
            end do
        end do
    else
        ! use good old trapeze rule
        tint = 0.0
        do j=1,n2
            do i=1,n1
                integ=0.0
                if (rev==0) then
                    do k=nzp,2,-1
                        integ = integ + 0.5*(tmp(i,j,k-1)+tmp(i,j,k))*(zpts(k-1)-zpts(k))
                        tint(i,j,k-1) = integ
                    end do
                    if (mapping==1) tint(i,j,1) = tint(i,j,2)
                else
                    do k=2,nzp
                        integ = integ + 0.5*(tmp(i,j,k-1)+tmp(i,j,k))*(zpts(k-1)-zpts(k))
                        tint(i,j,k) = integ
                    end do
                end if
            end do
        end do
    end if

end subroutine zinteg

subroutine test_zinteg(avgerr)
    ! test the accuracy of vertical integration
    use dim
    use runparam, only: mapping
    use paral
    use mpicom, only: myid
    ! i/o
    real, intent(out) :: avgerr
    ! vars
    integer :: k, AllocateStatus
    real, allocatable, dimension(:,:,:) :: dfdz, f_exact, f

    allocate(dfdz(nxpp,nypl,nzpl), f_exact(nxpp,nypl,nzpl), f(nxpp,nypl,nzpl), stat=AllocateStatus)
    if (AllocateStatus /= 0) then
        write(*,*) '**Error: not enough memory for allocation in test_zinteg**'
    end if
    ! let
    do k=1,nzp
        dfdz(:,:,k) = ubarp(k)
        f_exact(:,:,k) = (ubar(k)-ubar(nzp))
    end do
    call zinteg(dfdz,f,nx,nypl,mapping,0,0)
    avgerr = 0.0
    do k=1,nzp
        avgerr = avgerr + abs( f(1,1,k) - f_exact(1,1,k) )/nzp
    end do
    if (myid==0) then
        write(*,'(//,A)') '--------------test_zinteg results------------------'
        write(*,*) 'dfdz(z), f_exact(z), f_comp(z),'
        do k=1,nzp
            write(*,'(3(G12.4,'',''))') dfdz(1,1,k), f_exact(1,1,k), f(1,1,k)
        end do
        write(*,'(//,A,G12.4)') 'zinteg error =',avgerr
    end if
    deallocate(dfdz, f_exact, f)

end subroutine test_zinteg

subroutine dfdz(uf,dudzf)
    use dim
    use chebyshev
    use mats
    ! i/o
    real, dimension(nxpl,ny,nzpl), intent(in) :: uf
    real, dimension(nxpl,ny,nzpl), intent(out) :: dudzf
    ! vars
    integer :: i,j

    if (nz>31) then
        call dct_diff(nxpl,ny,nzp,uf,dudzf,1)
    else
        do j=1,ny
            do i=1,nxpl
                dudzf(i,j,:) = matmul(d,uf(i,j,:))
            end do
        end do
    end if

end subroutine dfdz

subroutine dpdz(n1,n2,n,u,dudz,p)
!     use dim
    use chebyshev
    use mats
    ! i/o
    integer, intent(in) :: n1, n2, n, p
    real, dimension(n1,n2,n), intent(in) :: u
    real, dimension(n1,n2,n), intent(out) :: dudz
    ! vars
    integer :: i,j,l

    if (n>31) then
        call dct_diff(n1,n2,n,u,dudz,p)
    else
        do j=1,n2
            do i=1,n1
                do l=1,p
                    dudz(i,j,:) = matmul(d,u(i,j,:))
                end do
            end do
        end do
    end if

end subroutine dpdz

subroutine d2fdz2(uf,dudz2f)
    use dim
    use chebyshev
    use mats
    ! i/o
    real, dimension(nxpl,ny,nzpl), intent(in) :: uf
    real, dimension(nxpl,ny,nzpl), intent(out) :: dudz2f
    ! vars
    integer :: i,j, err
    real, allocatable, dimension(:,:,:) :: dudzf

    allocate(dudzf(nxpl,ny,nzpl), stat=err)
    if (err /= 0) print *, "dudzf: Allocation request denied"

    if (nz>31) then
        call dct_diff(nxpl,ny,nzp,uf,dudz2f,2)
    else
        do j=1,ny
            do i=1,nxpl
                dudz2f(i,j,:) = matmul(d2,uf(i,j,:))
            end do
        end do
    end if

    if (allocated(dudzf)) deallocate(dudzf, stat=err)
    if (err /= 0) print *, "dudzf: Deallocation request denied"

end subroutine d2fdz2

subroutine test_dfdz()
    ! test accuracy of derivative
    use dim
    use grid
    use parameters, only: xlen
    use mpicom, only: myid
    use modhorfft
    use core
    use mats
    use chebyshev
    real, allocatable, dimension(:,:,:) ::  qf, dqf, q, dq, dq_exact
    real :: pi, avgerr
    integer :: i,j,k, AllocateStatus
    pi = 4.*atan(1.)
    ! allocate vars
    allocate( q(nxpp,nypl,nzpl), qf(nxpl,ny,nzpl), dq(nxpp,nypl,nzpl), dqf(nxpl,ny,nzpl), dq_exact(nxpp,nypl,nzpl), stat=AllocateStatus)
    if (AllocateStatus /= 0) then
        write(*,*) '**Error: not enough memory for allocation in test_dfdz**'
    end if
    ! test function
    qf = uf
    call horfft(q,qf,1)
    do j = 1, ny
        do i = 1, nxpl
            dqf(i,j,:) = matmul(d2,qf(i,j,:))
        end do
    end do
    call horfft(dq_exact,dqf,1)
    dqf = 0.0
!     do k = 1, nzp
!         do i = 1, nx
!             q(i,:,k) = exp(-((xpts(i)-xpts(nx/2))/(4.*dx))**2.0)*ubarp(k)
!             dq_exact(i,:,k) = exp(-((xpts(i)-xpts(nx/2))/(4.*dx))**2.0)*ubarpp(k)
!         end do
!     end do
    ! transfer to spectral space
!     call horfft(q,qf,-1)
    ! take derivative
!     call dfdz(qf,dqf)
    call d2fdz2(qf,dqf)
!     call dfdz(dqf,qf)
    ! transfer to phys space
    call horfft(dq,dqf,1)

    ! compute error
    avgerr = 0.0
    do k=1,nzp
        do j=1,nypl
            do i=1,nx
                avgerr = avgerr + abs( dq_exact(i,j,k) - dq(i,j,k) )/nzp/nx/nypl
            end do
        end do
    end do

    if (myid==2) then
        write(*,'(//,A)') '--------------test_dfdz results------------------'
        write(*,*) 'f(z), dfdz_exact, dfdz '
        do k=1,nzpl
            write(*,'(3(G15.7,'',''))') q(3,2,k), dq_exact(3,2,k), dq(3,2,k)
        end do
        write(*,'(//,A,G12.4)') 'dfdz avg error =',avgerr
!         do k=1,nzpl
!             write(*,'(32(G15.7,'',''))') dq(1:nx,2,k)
!         end do
    end if

    deallocate(q,qf,dq,dqf,dq_exact)
end subroutine test_dfdz

subroutine dfdx(uf,dudxf)
    ! uf (any primary var) in spectral space -> dudxf is its x-derivative
    use dim
    use grid, only: wavx
    real, dimension(nxpl,ny,nzpl), intent(in) :: uf
    real, dimension(nxpl,ny,nzpl), intent(out) :: dudxf
    integer :: i, k
    ! compute x derivative in Fourier space
    ! du/dx = ikx ( uf(2*i-1,:,:) + i*uf(2*i,:,:) )
    !        = ikx uf(2*i-1,:,:) - kx uf(2*i,:,:)
    ! dudxf(2*i,:,:) = kx uf(2*i-1,:,:)
    ! dudxf(2*i-1,:,:) = - kx uf(2*i,:,:)
    do k=1,nzpl
        do i=1,nxpl,2
            dudxf(i,:,k) = - wavx(i)*uf(i+1,:,k)
            dudxf(i+1,:,k) = wavx(i)*uf(i,:,k)
        end do
    end do

end subroutine dfdx

subroutine dfdy(uf,dudyf)
    ! uf (any primary var) in spectral space -> dudyf is its y-derivative
    use dim
    use grid, only: wavy
    real, dimension(nxpl,ny,nzpl), intent(in) :: uf
    real, dimension(nxpl,ny,nzpl), intent(out) :: dudyf
    integer :: i,k
    ! compute y derivative in Fourier space
    ! du/dy = iky ( uf(2*i-1,:,:) + i*uf(2*i,:,:) )
    !        = iky uf(2*i-1,:,:) - ky uf(2*i,:,:)
    ! dudyf(2*i,:,:) = ky uf(2*i-1,:,:)
    ! dudyf(2*i-1,:,:) = - ky uf(2*i,:,:)

    do k=1,nzpl
        do i=1,nxpl,2
            dudyf(i,:,k) = - wavy(:)*uf(i+1,:,k)
            dudyf(i+1,:,k) = wavy(:)*uf(i,:,k)
        end do
    end do

    end subroutine dfdy

subroutine lapl(uf,lapluf)
    ! takes laplacian (D^2-k^2) of uf
    use dim
    use grid, only: wavxx,wavyy
    ! input/output
    real, dimension(nxpl,ny,nzpl), intent(in) :: uf
    real, dimension(nxpl,ny,nzpl), intent(out) :: lapluf
    ! local vars
    integer :: j,k
    !     real :: wav2
    real, allocatable, dimension(:,:,:) :: dudz2f !, dudxf, dudyf
    allocate( dudz2f(nxpl,ny,nzpl) ) !, dudxf(nxpl,ny,nzpl), dudyf(nxpl,ny,nzpl) )
    call d2fdz2(uf,dudz2f) ! lapluf = d^2 u /dz^2
    do k=1,nzp
        do j=1,ny
            lapluf(:,j,k) = dudz2f(:,j,k) - (wavxx(:) + wavyy(j))*uf(:,j,k)
        enddo
    enddo
    deallocate( dudz2f )!, dudxf, dudyf )

end subroutine lapl

subroutine div(uf,vf,wf,divf)
    ! divf = ikx u + iky v + D w
    use dim
    use grid, only: wavx, wavy
    real, dimension(nxpl,ny,nzpl), intent(in) :: uf,vf,wf
    real, dimension(nxpl,ny,nzpl), intent(out) :: divf
    ! local vars
    !     integer :: i,j,k
    !     complex :: uderv, vderv
    real, allocatable, dimension(:,:,:) :: dqf
    allocate( dqf(nxpl,ny,nzpl) )
    ! compute dwdz
    call dfdz(wf,divf)
    ! compute x & y derivative in Fourier space
    call divuv(uf,vf,dqf)
    divf = dqf + divf
    deallocate( dqf )
end subroutine div

subroutine divcheck(uf,vf,wf,diverr)
    ! checks how far from zero is divergence of given field
    use dim
    use time, only: t,dt
    use modhorfft
    use formatstrings
    use mpicom, only: myid
    use flags, only: debug
    ! i/o
    real, dimension(nxpl,ny,nzpl), intent(in) :: uf,vf,wf
    real, intent(out) :: diverr
    ! local vars
    integer :: k!, i,j
    real, allocatable, dimension(:,:,:) :: divf, divp, dudxf,dvdyf,dwdzf
    allocate( divf(nxpl,ny,nzpl), divp(nxpp,nypl,nzpl), dudxf(nxpl,ny,nzpl), dvdyf(nxpl,ny,nzpl), dwdzf(nxpl,ny,nzpl) )
    ! calculate divergence
    call dfdx(uf,dudxf)
    call dfdy(vf,dvdyf)
    call dfdz(wf,dwdzf)
    divf = dudxf + dvdyf + dwdzf
    !     call div(uf,vf,wf,divf)
    call horfft(divp,divf,1)
    ! divp(nxp:nxpp,:,:) = 0.0
    ! calculate avg error
    diverr = sum( abs(divp) )/(nx*nypl*nzpl)
!     do k=1,nzp
!         do j=1,nypl
!             do i =1,nx
!                 diverr = diverr + abs(divp(i,j,k))/(nx*nypl*nzpl)
!             end do
!         end do
!     end do
    !     diverr = 0.0
    !     do k=1,nzp
    !         do j=1,nypl
    !             diverr = diverr + sum(abs(divp(1:nx,j,k)))/(nx*nypl*nzpl)
    !         end do
    !     end do

    if (myid==0) write(*,'(//,A,G14.6,A,G14.6,A,G14.6)') 'divergence avg error =', diverr, ', at t=',t,', and dt=',dt
    if (myid==0 .and. debug>=2) write(*,fm1) (divp(1:nx,1,k),k=1,nzp,nz)

    deallocate(divf,divp,dudxf,dvdyf,dwdzf)

end subroutine divcheck

subroutine divuv(uf,vf,divf)
    ! divf = ikx u + iky v + D w
    use dim
    use grid, only: wavx, wavy
    real, dimension(nxpl,ny,nzpl), intent(in) :: uf,vf
    real, dimension(nxpl,ny,nzpl), intent(out) :: divf
    integer :: i, k
    ! compute x & y derivative in Fourier space
    do k=1,nzpl
        do i=1,nxpl,2
            divf(i,:,k) = - wavx(i)*uf(i+1,:,k) - wavy(:)*vf(i+1,:,k)
            divf(i+1,:,k) = wavx(i)*uf(i,:,k)   + wavy(:)*vf(i,:,k)
        end do
    end do

end subroutine divuv

subroutine test_dfdx()
    ! test accuracy of derivative
    use dim
    use grid
    use parameters, only: xlen
    use mpicom, only: myid
    use modhorfft
    real, allocatable, dimension(:,:,:) ::  qf, dqf, q, dq, dq_exact
    real :: pi, avgerr
    integer :: i
    pi = 4.*atan(1.)
    ! allocate vars
    allocate( q(nxpp,nypl,nzpl), qf(nxpl,ny,nzpl), dq(nxpp,nypl,nzpl), dqf(nxpl,ny,nzpl), dq_exact(nxpp,nypl,nzpl))
    ! test function
    do i=1,nx
        q(i,:,:) = exp(-((xpts(i)-xpts(nx/2))/(4.*dx))**2.0)
        !cos(6.*pi*(xpts(i)-xpts(1))/xlen)
        dq_exact(i,:,:) = -2.0*(xpts(i)-xpts(nx/2))*exp(-((xpts(i)-xpts(nx/2))/(4.*dx))**2.0)/(4.*dx)**2.0
        !-6.*pi/xlen*sin(6.*pi*(xpts(i)-xpts(1))/xlen)
    end do

    ! transfer to spectral space
    call horfft(q,qf,-1)
    ! take derivative
    call dfdx(qf,dqf)
    ! transfer to phys space
    call horfft(dq,dqf,1)

    ! compute error
    avgerr = 0.0
    do i=1,nx
        avgerr = avgerr + abs( dq_exact(i,1,1) - dq(i,1,1) )/nx
    end do

    if (myid==0) then
        write(*,'(//,A)') '--------------test_dfdx results------------------'
        write(*,*) 'f(x), dfdx_exact, dfdx '
        do i=1,nx
            write(*,'(3(G15.7,'',''))') q(i,2,3), dq_exact(i,2,3), dq(i,2,3)
        end do
        write(*,'(//,A,G12.4)') 'dfdx avg error =',avgerr
    end if

    deallocate(q,qf,dq,dqf,dq_exact)

end subroutine test_dfdx

subroutine test_dfdy()
    ! test accuracy of derivative
    use dim
    use grid
    use parameters, only: ylen
    use mpicom
    use modhorfft
    real, allocatable, dimension(:,:,:) ::  qf, dqf, q, dq, dq_exact
    real :: pi, avgerr, totalavgerr
    integer :: j
    pi = 4.*atan(1.)
    ! allocate vars
    allocate( q(nxpp,nypl,nzpl), qf(nxpl,ny,nzpl), dq(nxpp,nypl,nzpl), dqf(nxpl,ny,nzpl), dq_exact(nxpp,nypl,nzpl))
    ! test function
    do j=1,nypl
        q(:,j,:) = exp(-((y(j)-ypts(ny/2))/(4.*dy))**2.0)
        !cos(6.*pi*y(j)/ylen)
        dq_exact(:,j,:) = -2.0*(y(j)-ypts(ny/2))*exp(-((y(j)-ypts(ny/2))/(4.*dy))**2.0)/(4.*dy)**2.0
        !-6.*pi/ylen*sin(6.*pi*y(j)/ylen)
    end do

    ! transfer to spectral space
    call horfft(q,qf,-1)
    ! take derivative
    call dfdy(qf,dqf)
    ! transfer to phys space
    call horfft(dq,dqf,1)

    ! compute error
    avgerr = 0.0
    do j=1,nypl
        avgerr = avgerr + abs( dq_exact(1,j,1) - dq(1,j,1) )/ny
    end do

    call mpi_reduce(avgerr,totalavgerr,1,mpi_double_precision,MPI_SUM,0,comm,ierr)

    if (myid==0) then
        write(*,'(//,A)') '--------------test_dfdy results------------------'
        write(*,*) 'f(y), dfdy_exact, dfdy '
        do j=1,nypl
            write(*,'(3(G15.7,'',''))') q(1,j,1), dq_exact(1,j,1), dq(1,j,1)
        end do
        write(*,'(//,A,G12.4)') 'dfdy avg error =',avgerr
    end if

    deallocate(q,qf,dq,dqf,dq_exact)

end subroutine test_dfdy

subroutine test_lapl()
    ! computes laplacian of known function to check accuracy
    use dim
    use mpicom
    use modhorfft
    use paral
    use grid
    ! use parameters, only: xlen, ylen
    use formatstrings
    ! local vars
    integer :: i,j,k
    real :: avgerr, totalavgerr
    real, allocatable, dimension(:,:,:) :: q, laplq, qf, laplqf, laplq_exact
    ! real :: lx, ly
    real :: a, b, x, f

    allocate( q(nxpp,nypl,nzpl), laplq(nxpp,nypl,nzpl), laplq_exact(nxpp,nypl,nzpl), qf(nxpl,ny,nzpl), laplqf(nxpl,ny,nzpl) )

    b = xpts(nx/2)
    a = 4.*dx
    ! lx = xpts(nx) - xpts(1)
    ! ly = ypts(ny) - ypts(1)
    ! pi = 4.*atan(1.)
    do k=1,nzpl
        do j=1,nypl
            do i=1,nx
                x = xpts(i)
                f = exp(-((x-b)/a)**2.0)
                q(i,j,k) = ubar(k) + 0.1*ubar(k)*f
                laplq_exact(i,j,k) = ubarpp(k) + 0.1*ubarpp(k)*f + 0.1*ubar(k)*f*(4.*(b-x)**2.0-2.0*a**2.0)/a**4.
    !             q(i,j,k) = wbar(k) + 0.1*wbar(k)*sin(4.*pi*(xpts(i)-xpts(1))/lx) !+ 0.1*wbar(k)*sin(4.*pi*y(j)/ly)
    !             laplq_exact(i,j,k) = wbarpp(k) + 0.1*wbarpp(k)*sin(4.*pi*(xpts(i)-xpts(1))/lx)  - (4.*pi/lx)*0.1*wbar(k)*sin(4.*pi*(xpts(i)-xpts(1))/lx) ! + 0.1*wbarpp(k)*sin(4.*pi*y(j)/ly) - (4.*pi/ly)*0.1*wbar(k)*sin(4.*pi*y(j)/ly)
            end do
        end do
    end do

    call horfft(q,qf,-1)
    call lapl(qf,laplqf)
    call horfft(laplq,laplqf,1)

    ! compute error
    avgerr = 0.0
    do k=1,nzpl
        do j=1,nypl
            do i=1,nx
                avgerr = avgerr + abs( laplq_exact(i,j,k) - laplq(i,j,k) ) /(nx*ny*nzp)
            end do
        end do
    end do

    call mpi_reduce(avgerr,totalavgerr,1,mpi_double_precision,MPI_SUM,0,comm,ierr)

    if (myid==0) then
        write(*,'(//,A)') '--------------test_lapl results------------------'
        write(*,'(A,G12.4)') 'lapl avg error =',totalavgerr
        write(*,*) 'q(x,1,nz) ='
        write(*,fm1) q(1:nx,2,nz/2)
        write(*,*) 'q(1,y,nz) ='
        write(*,fm2) q(4,1:nypl,nz/2)
        write(*,*) 'q(1,1,z) ='
        write(*,fm3) q(4,2,1:nzp)
        write(*,*) 'laplq_exact(x,1,nz) ='
        write(*,fm1) laplq_exact(1:nx,2,nz/2)
        write(*,*) 'laplq_exact(1,y,nz) ='
        write(*,fm2) laplq_exact(4,1:nypl,nz/2)
        write(*,*) 'laplq_exact(1,1,z) ='
        write(*,fm3) laplq_exact(4,2,1:nzp)
        write(*,*) 'laplq(x,1,nz) ='
        write(*,fm1) laplq(1:nx,2,nz/2)
        write(*,*) 'laplq(1,y,nz) ='
        write(*,fm2) laplq(4,1:nypl,nz/2)
        write(*,*) 'laplq(1,1,z) ='
        write(*,fm3) laplq(4,2,1:nzp)
    end if

    deallocate( q, laplq, qf, laplqf, laplq_exact )

end subroutine test_lapl

end module derivatives


program vin
  integer :: numbers(9),k1,k2
  numbers = 3
  numbers(1:5) = numbers(4:8) + (/ (k1,k1=1,5) /)  + (/ (k2,k2=5,9) /)
  print *,numbers
end program vin


      SUBROUTINE DPBSL(ABD, LDA, N, M, B)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
!...Translated by Pacific-Sierra Research 77to90  4.3E  21:52:17  11/14/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE ddot_I
      USE daxpy_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER , INTENT(IN) :: LDA
      INTEGER , INTENT(IN) :: N
      INTEGER , INTENT(IN) :: M
      REAL(DOUBLE)  :: ABD(LDA,1)
      REAL(DOUBLE)  :: B(1)
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: K, KB, LA, LB, LM
      REAL(DOUBLE) :: T
!-----------------------------------------------
!
!     DPBSL SOLVES THE DOUBLE PRECISION SYMMETRIC POSITIVE DEFINITE
!     BAND SYSTEM  A*X = B
!     USING THE FACTORS COMPUTED BY DPBCO OR DPBFA.
!
!     ON ENTRY
!
!        ABD     DOUBLE PRECISION(LDA, N)
!                THE OUTPUT FROM DPBCO OR DPBFA.
!
!        LDA     INTEGER
!                THE LEADING DIMENSION OF THE ARRAY  ABD .
!
!        N       INTEGER
!                THE ORDER OF THE MATRIX  A .
!
!        M       INTEGER
!                THE NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL.
!
!        B       DOUBLE PRECISION(N)
!                THE RIGHT HAND SIDE VECTOR.
!
!     ON RETURN
!
!        B       THE SOLUTION VECTOR  X .
!
!     ERROR CONDITION
!
!        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS
!        A ZERO ON THE DIAGONAL.  TECHNICALLY THIS INDICATES
!        SINGULARITY BUT IT IS USUALLY CAUSED BY IMPROPER SUBROUTINE
!        ARGUMENTS.  IT WILL NOT OCCUR IF THE SUBROUTINES ARE CALLED
!        CORRECTLY AND  INFO .EQ. 0 .
!
!     TO COMPUTE  INVERSE(A) * C  WHERE  C  IS A MATRIX
!     WITH  P  COLUMNS
!           CALL DPBCO(ABD,LDA,N,RCOND,Z,INFO)
!           IF (RCOND IS TOO SMALL .OR. INFO .NE. 0) GO TO ...
!           DO 10 J = 1, P
!              CALL DPBSL(ABD,LDA,N,C(1,J))
!        10 CONTINUE
!
!     LINPACK.  THIS VERSION DATED 08/14/78 .
!     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
!
!     SUBROUTINES AND FUNCTIONS
!
!     BLAS DAXPY,DDOT
!     FORTRAN MIN0
!
!     INTERNAL VARIABLES
!
!
!     SOLVE TRANS(R)*Y = B
!
      DO K = 1, N
         LM = MIN0(K - 1,M)
         LA = M + 1 - LM
         LB = K - LM
         T = DDOT(LM,ABD(LA,K),1,B(LB),1)
         B(K) = (B(K)-T)/ABD(M+1,K)
      END DO
!
!     SOLVE R*X = Y
!
      DO KB = 1, N
         K = N + 1 - KB
         LM = MIN0(K - 1,M)
         LA = M + 1 - LM
         LB = K - LM
         B(K) = B(K)/ABD(M+1,K)
         T = -B(K)
         CALL DAXPY (LM, T, ABD(LA,K), 1, B(LB), 1)
      END DO
!
!     SOLVE R*X = Y
!
      RETURN
      END SUBROUTINE DPBSL


      FUNCTION DT_CKMTFF(X,Fvl)
      IMPLICIT NONE
      REAL aloga , alpha , axi , axj , axk , beta , bxi , bxj , bxk ,
     &     det , DT_CKMTFF , fi , fj , fk , Fvl , X , xgrid
      INTEGER i , j , k , nx
C**********************************************************************
C
C     LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
C     FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
C     NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
C     IN MAIN ROUTINE.
C
C**********************************************************************

      SAVE
      DIMENSION Fvl(25) , xgrid(25)
      DATA nx , xgrid/25 , .001 , .002 , .004 , .008 , .016 , .032 ,
     &     .064 , .1 , .15 , .2 , .25 , .3 , .35 , .4 , .45 , .5 , .55 ,
     &     .6 , .65 , .7 , .75 , .8 , .85 , .9 , .95/
C
      DT_CKMTFF = 0.
      DO i = 1 , nx
         IF ( X.LT.xgrid(i) ) GOTO 100
      END DO
 100  i = i - 1
      IF ( i.EQ.0 ) THEN
         i = i + 1
      ELSE IF ( i.GT.23 ) THEN
         i = 23
      END IF
      j = i + 1
      k = j + 1
      axi = LOG(xgrid(i))
      bxi = LOG(1.-xgrid(i))
      axj = LOG(xgrid(j))
      bxj = LOG(1.-xgrid(j))
      axk = LOG(xgrid(k))
      bxk = LOG(1.-xgrid(k))
      fi = LOG(ABS(Fvl(i))+1.E-15)
      fj = LOG(ABS(Fvl(j))+1.E-16)
      fk = LOG(ABS(Fvl(k))+1.E-17)
      det = axi*(bxj-bxk) + axj*(bxk-bxi) + axk*(bxi-bxj)
      aloga = (fi*(axj*bxk-axk*bxj)+fj*(axk*bxi-axi*bxk)
     &        +fk*(axi*bxj-axj*bxi))/det
      alpha = (fi*(bxj-bxk)+fj*(bxk-bxi)+fk*(bxi-bxj))/det
      beta = (fi*(axk-axj)+fj*(axi-axk)+fk*(axj-axi))/det
      IF ( ABS(alpha).GT.99. .OR. ABS(beta).GT.99. .OR. ABS(aloga)
     &     .GT.99. ) RETURN
C      IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
C         WRITE(6,2001) X,FVL
C 2001    FORMAT(8E12.4)
C         WRITE(6,2001) ALPHA,BETA,ALOGA,DET
C      ENDIF
      DT_CKMTFF = EXP(aloga)*X**alpha*(1.-X)**beta
      END FUNCTION