module eigen
    implicit none
    external ZHEEV

    complex*16, dimension(1:4, 1:4) :: Gamma1, Gamma2, Gamma3, Gamma4, Gamma5, Ident

    type :: Mnk12Params
        double precision :: gamma_fm, Delta_n, M, A, B, E_F, C, gamma_c
    end type Mnk12Params
contains
    ! Call LAPACK routine ZHEEV to get eigenvalues and eigenvectors of the
    ! Hermitian, upper triangular matrix H of order N.
    ! Returns 0 on success.
    function EigenDecomp(H, N, eigenvals)
        complex*16, dimension(1:N, 1:N), intent(inout) :: H
        integer, intent(in) :: N
        double precision, dimension(1:N), intent(out) :: eigenvals
        complex*16, dimension(1:1) :: first_work
        double precision, dimension(1:3*N-2) :: rwork
        complex*16, dimension(:), allocatable :: work
        integer :: EigenDecomp, opt_lwork
        if (N <= 0) then
            ! TODO - handle invalid argument
            return
        end if
        ! get the optimal value for lwork
        call ZHEEV('V', 'U', N, H, N, eigenvals, first_work, -1, rwork, EigenDecomp)
        if (EigenDecomp /= 0) then
            return
        end if
        opt_lwork = first_work(1)
        ! Make optimal sized work array.
        ! allocate() crashes on error; TODO handle?
        ! Can get error code with allocate(work(1:opt_lwork), STAT=code)
        ! error if code = 0
        allocate(work(1:opt_lwork))
        ! make the real call to ZHEEV
        call ZHEEV('V', 'U', N, H, N, eigenvals, work, opt_lwork, rwork, EigenDecomp)
    end function EigenDecomp

    subroutine InitGammas()
        ! Liu (2010) notation for Gamma matrices
        Gamma1(:, 1) = (/(0.0D0, 0.0D0), (0.0D0, 0.0D0), (0.0D0, 0.0D0), (1.0D0, 0.0D0)/)
        Gamma1(:, 2) = (/(0.0D0, 0.0D0), (0.0D0, 0.0D0), (1.0D0, 0.0D0), (0.0D0, 0.0D0)/)
        Gamma1(:, 3) = (/(0.0D0, 0.0D0), (1.0D0, 0.0D0), (0.0D0, 0.0D0), (0.0D0, 0.0D0)/)
        Gamma1(:, 4) = (/(1.0D0, 0.0D0), (0.0D0, 0.0D0), (0.0D0, 0.0D0), (0.0D0, 0.0D0)/)

        Gamma2(:, 1) = (/(0.0D0, 0.0D0), (0.0D0, 0.0D0), (0.0D0, 0.0D0), (0.0D0, -1.0D0)/)
        Gamma2(:, 2) = (/(0.0D0, 0.0D0), (0.0D0, 0.0D0), (0.0D0, -1.0D0), (0.0D0, 0.0D0)/)
        Gamma2(:, 3) = (/(0.0D0, 0.0D0), (0.0D0, 1.0D0), (0.0D0, 0.0D0), (0.0D0, 0.0D0)/)
        Gamma2(:, 4) = (/(0.0D0, 1.0D0), (0.0D0, 0.0D0), (0.0D0, 0.0D0), (0.0D0, 0.0D0)/)

        Gamma3(:, 1) = (/(0.0D0, 0.0D0), (1.0D0, 0.0D0), (0.0D0, 0.0D0), (0.0D0, 0.0D0)/)
        Gamma3(:, 2) = (/(1.0D0, 0.0D0), (0.0D0, 0.0D0), (0.0D0, 0.0D0), (0.0D0, 0.0D0)/)
        Gamma3(:, 3) = (/(0.0D0, 0.0D0), (0.0D0, 0.0D0), (0.0D0, 0.0D0), (-1.0D0, 0.0D0)/)
        Gamma3(:, 4) = (/(0.0D0, 0.0D0), (0.0D0, 0.0D0), (-1.0D0, 0.0D0), (0.0D0, 0.0D0)/)

        Gamma4(:, 1) = (/(0.0D0, 0.0D0), (0.0D0, -1.0D0), (0.0D0, 0.0D0), (0.0D0, 0.0D0)/)
        Gamma4(:, 2) = (/(0.0D0, 1.0D0), (0.0D0, 0.0D0), (0.0D0, 0.0D0), (0.0D0, 0.0D0)/)
        Gamma4(:, 3) = (/(0.0D0, 0.0D0), (0.0D0, 0.0D0), (0.0D0, 0.0D0), (0.0D0, -1.0D0)/)
        Gamma4(:, 4) = (/(0.0D0, 0.0D0), (0.0D0, 0.0D0), (0.0D0, 1.0D0), (0.0D0, 0.0D0)/)

        Gamma5(:, 1) = (/(1.0D0, 0.0D0), (0.0D0, 0.0D0), (0.0D0, 0.0D0), (0.0D0, 0.0D0)/)
        Gamma5(:, 2) = (/(0.0D0, 0.0D0), (-1.0D0, 0.0D0), (0.0D0, 0.0D0), (0.0D0, 0.0D0)/)
        Gamma5(:, 3) = (/(0.0D0, 0.0D0), (0.0D0, 0.0D0), (1.0D0, 0.0D0), (0.0D0, 0.0D0)/)
        Gamma5(:, 4) = (/(0.0D0, 0.0D0), (0.0D0, 0.0D0), (0.0D0, 0.0D0), (-1.0D0, 0.0D0)/)

        Ident(:, 1) = (/(1.0D0, 0.0D0), (0.0D0, 0.0D0), (0.0D0, 0.0D0), (0.0D0, 0.0D0)/)
        Ident(:, 2) = (/(0.0D0, 0.0D0), (1.0D0, 0.0D0), (0.0D0, 0.0D0), (0.0D0, 0.0D0)/)
        Ident(:, 3) = (/(0.0D0, 0.0D0), (0.0D0, 0.0D0), (1.0D0, 0.0D0), (0.0D0, 0.0D0)/)
        Ident(:, 4) = (/(0.0D0, 0.0D0), (0.0D0, 0.0D0), (0.0D0, 0.0D0), (1.0D0, 0.0D0)/)
    end subroutine

    function DefaultMnk12Params()
        type(Mnk12Params) :: DefaultMnk12Params
        DefaultMnk12Params%gamma_fm = 1.0D0
        DefaultMnk12Params%Delta_n = 1.0D0
        DefaultMnk12Params%M = 0.3D0
        DefaultMnk12Params%A = 0.5D0
        DefaultMnk12Params%B = 0.25D0
        DefaultMnk12Params%E_F = 3.1D0
        DefaultMnk12Params%C = 3.0D0
        DefaultMnk12Params%gamma_c = 0.25D0
    end function DefaultMnk12Params

    function EigenMnk12(p, numLayers, k, eigenvals, eigenvectors)
        type(Mnk12Params), intent(in) :: p
        integer, intent(in) :: numLayers
        double precision, dimension(1:2) :: k
        double precision, dimension(1:4*numLayers), intent(out) :: eigenvals
        complex*16, dimension(1:4*numLayers, 1:4*numLayers), intent(out) :: eigenvectors
        integer :: EigenMnk12, i
        complex*16, dimension(1:4, 1:4) :: diagonal, cross, cross_conj
        call InitGammas()

        ! block-diagonal piece
        diagonal = p%C*Ident + (p%M + 2.0D0*p%B*(cos(k(1)) + cos(k(2)) - 3.0D0))*Gamma5 &
                     + p%A*(sin(k(1))*Gamma2 + sin(k(2))*Gamma1)
        ! hop layer n+1 to n
        cross = p%B*Gamma5 - (0.0D0, 0.5D0)*p%A*Gamma4
        ! hop layer n to n+1
        cross_conj = conjg(transpose(cross))

        ! initialize Hamiltonian
        eigenvectors(:, :) = (0.0D0, 0.0D0)
        do i=1, 4*numLayers, 4  ! i = 1, 5, 9, ..., 4*numLayers - 3
            eigenvectors(i:i+3, i:i+3) = diagonal
            if (i < 4*numLayers - 3) then
                eigenvectors(i+4:i+7, i:i+3) = cross
            end if
            if (i > 1) then
                eigenvectors(i-4:i-1, i:i+3) = cross_conj
            end if
        end do
        EigenMnk12 = EigenDecomp(eigenvectors, 4*numLayers, eigenvals)
        if (EigenMnk12 /= 0) then
            ! TODO handle error
        end if
    end function EigenMnk12
end module eigen


      do ep=-2,0
      S0000i(1,ep)=-2d0*Csum00(ep)+2d0*m1*Dv(dd001+N0,ep)
      S0000i(2,ep)=+2d0*Cv(cc001+C234,ep)+2d0*m1*Dv(dd002+N0,ep)
      S0000i(3,ep)=+2d0*Cv(cc002+C234,ep)+2d0*m1*Dv(dd003+N0,ep)
      enddo


!*==slaorhr_col_getrfnp.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b SLAORHR_COL_GETRFNP
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download SLAORHR_COL_GETRFNP + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE SLAORHR_COL_GETRFNP( M, N, A, LDA, D, INFO )
!
!       .. Scalar Arguments ..
!       INTEGER            INFO, LDA, M, N
!       ..
!       .. Array Arguments ..
!       REAL               A( LDA, * ), D( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> SLAORHR_COL_GETRFNP computes the modified LU factorization without
!> pivoting of a real general M-by-N matrix A. The factorization has
!> the form:
!>
!>     A - S = L * U,
!>
!> where:
!>    S is a m-by-n diagonal sign matrix with the diagonal D, so that
!>    D(i) = S(i,i), 1 <= i <= min(M,N). The diagonal D is constructed
!>    as D(i)=-SIGN(A(i,i)), where A(i,i) is the value after performing
!>    i-1 steps of Gaussian elimination. This means that the diagonal
!>    element at each step of "modified" Gaussian elimination is
!>    at least one in absolute value (so that division-by-zero not
!>    not possible during the division by the diagonal element);
!>
!>    L is a M-by-N lower triangular matrix with unit diagonal elements
!>    (lower trapezoidal if M > N);
!>
!>    and U is a M-by-N upper triangular matrix
!>    (upper trapezoidal if M < N).
!>
!> This routine is an auxiliary routine used in the Householder
!> reconstruction routine SORHR_COL. In SORHR_COL, this routine is
!> applied to an M-by-N matrix A with orthonormal columns, where each
!> element is bounded by one in absolute value. With the choice of
!> the matrix S above, one can show that the diagonal element at each
!> step of Gaussian elimination is the largest (in absolute value) in
!> the column on or below the diagonal, so that no pivoting is required
!> for numerical stability [1].
!>
!> For more details on the Householder reconstruction algorithm,
!> including the modified LU factorization, see [1].
!>
!> This is the blocked right-looking version of the algorithm,
!> calling Level 3 BLAS to update the submatrix. To factorize a block,
!> this routine calls the recursive routine SLAORHR_COL_GETRFNP2.
!>
!> [1] "Reconstructing Householder vectors from tall-skinny QR",
!>     G. Ballard, J. Demmel, L. Grigori, M. Jacquelin, H.D. Nguyen,
!>     E. Solomonik, J. Parallel Distrib. Comput.,
!>     vol. 85, pp. 3-31, 2015.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] M
!> \verbatim
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the M-by-N matrix to be factored.
!>          On exit, the factors L and U from the factorization
!>          A-S=L*U; the unit diagonal elements of L are not stored.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!> \endverbatim
!>
!> \param[out] D
!> \verbatim
!>          D is REAL array, dimension min(M,N)
!>          The diagonal elements of the diagonal M-by-N sign matrix S,
!>          D(i) = S(i,i), where 1 <= i <= min(M,N). The elements can
!>          be only plus or minus one.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!> \endverbatim
!>
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date November 2019
!
!> \ingroup realGEcomputational
!
!> \par Contributors:
!  ==================
!>
!> \verbatim
!>
!> November 2019, Igor Kozachenko,
!>                Computer Science Division,
!>                University of California, Berkeley
!>
!> \endverbatim
!
!  =====================================================================
      SUBROUTINE SLAORHR_COL_GETRFNP(M,N,A,Lda,D,Info)
      IMPLICIT NONE
!*--SLAORHR_COL_GETRFNP150
!
!  -- LAPACK computational routine (version 3.9.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     November 2019
!
!     .. Scalar Arguments ..
      INTEGER Info , Lda , M , N
!     ..
!     .. Array Arguments ..
      REAL A(Lda,*) , D(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ONE
      PARAMETER (ONE=1.0E+0)
!     ..
!     .. Local Scalars ..
      INTEGER iinfo , j , jb , nb
!     ..
!     .. External Subroutines ..
      EXTERNAL SGEMM , SLAORHR_COL_GETRFNP2 , STRSM , XERBLA
!     ..
!     .. External Functions ..
      INTEGER ILAENV
      EXTERNAL ILAENV
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX , MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      Info = 0
      IF ( M<0 ) THEN
         Info = -1
      ELSEIF ( N<0 ) THEN
         Info = -2
      ELSEIF ( Lda<MAX(1,M) ) THEN
         Info = -4
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('SLAORHR_COL_GETRFNP',-Info)
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( MIN(M,N)==0 ) RETURN
!
!     Determine the block size for this environment.
!

      nb = ILAENV(1,'SLAORHR_COL_GETRFNP',' ',M,N,-1,-1)

      IF ( nb<=1 .OR. nb>=MIN(M,N) ) THEN
!
!        Use unblocked code.
!
         CALL SLAORHR_COL_GETRFNP2(M,N,A,Lda,D,Info)
      ELSE
!
!        Use blocked code.
!
         DO j = 1 , MIN(M,N) , nb
            jb = MIN(MIN(M,N)-j+1,nb)
!
!           Factor diagonal and subdiagonal blocks.
!
            CALL SLAORHR_COL_GETRFNP2(M-j+1,jb,A(j,j),Lda,D(j),iinfo)
!
            IF ( j+jb<=N ) THEN
!
!              Compute block row of U.
!
               CALL STRSM('Left','Lower','No transpose','Unit',jb,      &
     &                    N-j-jb+1,ONE,A(j,j),Lda,A(j,j+jb),Lda)
!
!                 Update trailing submatrix.
!
               IF ( j+jb<=M ) CALL SGEMM('No transpose','No transpose', &
     &              M-j-jb+1,N-j-jb+1,jb,-ONE,A(j+jb,j),Lda,A(j,j+jb),  &
     &              Lda,ONE,A(j+jb,j+jb),Lda)
            ENDIF
         ENDDO
      ENDIF
!
!     End of SLAORHR_COL_GETRFNP
!
      END SUBROUTINE SLAORHR_COL_GETRFNP


subroutine trispline(f,x,y,z,n1,n2,n3,t1,t2,t3,fx,fy,fxy)
!subroutine trispline(f,x,y,z,n1,n2,n3,t1,t2,t3,fx,fy,fz,fxy,fxz,fyz,fxyz)
!     constructs interpolation coefficients for a periodic
!     function f evaluated on a
!     three dimensional grid (x,y,z) with size n1 x n2 x n3.
!     t1,t2,t3 are the periods.
implicit none
integer n1,n2,n3
double precision f(n1,n2,n3),x(n1),y(n2),z(n3),t1,t2,t3
double precision fx(n1,n2,n3),fy(n1,n2,n3),fxy(n1,n2,n3)   !, &
!&                fz(n1,n2,n3),fxz(n1,n2,n3),fyz(n1,n2,n3), &
!&                fxyz(n1,n2,n3)
double precision, allocatable :: coefs(:)
integer ii,jj,kk

allocate (coefs(n1))
do jj=1,n2
do kk=1,n3
  call spline(f(:,jj,kk),x,n1,t1,coefs)
  call dspline(f(:,jj,kk),x,coefs,n1,fx(:,jj,kk))
enddo
enddo

deallocate (coefs)
allocate (coefs(n2))
do ii=1,n1
do kk=1,n3
  call spline(f(ii,:,kk),y,n2,t2,coefs)
  call dspline(f(ii,:,kk),y,coefs,n2,fy(ii,:,kk))
  call spline(fx(ii,:,kk),y,n2,t2,coefs)
  call dspline(fx(ii,:,kk),y,coefs,n2,fxy(ii,:,kk))
enddo
enddo

!deallocate (coefs)
!allocate (coefs(n3))
!do ii=1,n1
!do jj=1,n2
!  call spline(f(ii,jj,:),z,n3,t3,coefs)
!  call dspline(f(ii,jj,:),z,coefs,n3,fz(ii,jj,:))
!  call spline(fx(ii,jj,:),z,n3,t3,coefs)
!  call dspline(fx(ii,jj,:),z,coefs,n3,fxz(ii,jj,:))
!  call spline(fy(ii,jj,:),z,n3,t3,coefs)
!  call dspline(fy(ii,jj,:),z,coefs,n3,fyz(ii,jj,:))
!  call spline(fxy(ii,jj,:),z,n3,t3,coefs)
!  call dspline(fxy(ii,jj,:),z,coefs,n3,fxyz(ii,jj,:))
!enddo
!enddo

return
end subroutine trispline

!***************************************************************************

subroutine xyzspline(f,x,y,z,n1,n2,n3,t1,t2,t3,fx,fy,fz,fxy,fxz,fyz,fxyz)
!     constructs interpolation coefficients for a periodic
!     function f evaluated on a
!     three dimensional grid (x,y,z) with size n1 x n2 x n3.
!     t1,t2,t3 are the periods.
implicit none
integer n1,n2,n3
double precision f(n1,n2,n3),x(n1),y(n2),z(n3),t1,t2,t3
double precision fx(n1,n2,n3),fy(n1,n2,n3),fxy(n1,n2,n3), &
&                fz(n1,n2,n3),fxz(n1,n2,n3),fyz(n1,n2,n3), &
&                fxyz(n1,n2,n3)
double precision, allocatable :: coefs(:)
integer ii,jj,kk

allocate (coefs(n1))
do jj=1,n2
do kk=1,n3
  call spline(f(:,jj,kk),x,n1,t1,coefs)
  call dspline(f(:,jj,kk),x,coefs,n1,fx(:,jj,kk))
enddo
enddo

deallocate (coefs)
allocate (coefs(n2))
do ii=1,n1
do kk=1,n3
  call spline(f(ii,:,kk),y,n2,t2,coefs)
  call dspline(f(ii,:,kk),y,coefs,n2,fy(ii,:,kk))
  call spline(fx(ii,:,kk),y,n2,t2,coefs)
  call dspline(fx(ii,:,kk),y,coefs,n2,fxy(ii,:,kk))
enddo
enddo

deallocate (coefs)
allocate (coefs(n3))
do ii=1,n1
do jj=1,n2
  call spline(f(ii,jj,:),z,n3,t3,coefs)
  call dspline(f(ii,jj,:),z,coefs,n3,fz(ii,jj,:))
  call spline(fx(ii,jj,:),z,n3,t3,coefs)
  call dspline(fx(ii,jj,:),z,coefs,n3,fxz(ii,jj,:))
  call spline(fy(ii,jj,:),z,n3,t3,coefs)
  call dspline(fy(ii,jj,:),z,coefs,n3,fyz(ii,jj,:))
  call spline(fxy(ii,jj,:),z,n3,t3,coefs)
  call dspline(fxy(ii,jj,:),z,coefs,n3,fxyz(ii,jj,:))
enddo
enddo

return
end subroutine xyzspline

!***************************************************************************

subroutine spl23(f,fx,fy,fxy,x,y,z,n1,n2,n3,t1,t2,t3,xv,yv,nz,zv,fv)
implicit none
integer :: n1,n2,n3,nz
double precision :: f(n1,n2,n3),x(n1),y(n2),z(n3),t1,t2,t3,xv,yv,zv(nz)
double precision :: fv(nz)
double precision :: fx(n1,n2,n3),fy(n1,n2,n3),fxy(n1,n2,n3),zvals(n3)
double precision, allocatable :: coefs(:)
double precision :: veca(4),vecb(4),dmat(4,4)
integer :: ii,jj,kk
integer :: ihi,ilo,jhi,jlo
double precision :: dx,dxg,dy,dyg

if (xv.lt.x(1)) then
  ihi=1
  ilo=n1
  dxg=x(ihi)-x(ilo)+t1
  dx=(xv-x(ilo)+t1)/dxg
else
  ihi=n1
  ilo=1
  do
    if (ihi-ilo.le.1) exit
    ii=(ihi+ilo)/2
    if (x(ii).gt.xv) then
      ihi=ii
    else
      ilo=ii
    endif
  enddo
  dxg=x(ihi)-x(ilo)
  dx=(xv-x(ilo))/dxg
endif

if (yv.lt.y(1)) then
  jhi=1
  jlo=n2
  dyg=y(jhi)-y(jlo)+t2
  dy=(yv-y(jlo)+t2)/dyg
else
  jhi=n2
  jlo=1
  do
    if (jhi-jlo.le.1) exit
    jj=(jhi+jlo)/2
    if (y(jj).gt.yv) then
      jhi=jj
    else
      jlo=jj
    endif
  enddo
  dyg=y(jhi)-y(jlo)
  dy=(yv-y(jlo))/dyg
endif

!if (zv.lt.z(1)) then
!  khi=1
!  klo=n3
!  dzg=z(khi)-z(klo)+t3
!  dz=(zv-z(klo)+t3)/dzg
!else
!  khi=n3
!  klo=1
!  do
!    if (khi-klo.le.1) exit
!    kk=(khi+klo)/2
!    if (z(kk).gt.zv) then
!      khi=kk
!    else
!      klo=kk
!    endif
!  enddo
!  dzg=z(khi)-z(klo)
!  dz=(zv-z(klo))/dzg
!endif

do kk=1,n3
!  allocate (coefs(n1))
!  do jj=1,n2
!    call spline(f(:,jj,kk),x,n1,t1,coefs)
!    call dspline(f(:,jj,kk),x,coefs,n1,fx(:,jj,kk))
!  enddo
!  deallocate (coefs)
!
!  allocate (coefs(n2))
!  do ii=1,n1
!    call spline(f(ii,:,kk),y,n2,t2,coefs)
!    call dspline(f(ii,:,kk),y,coefs,n2,fy(ii,:,kk))
!    call spline(fx(ii,:,kk),y,n2,t2,coefs)
!    call dspline(fx(ii,:,kk),y,coefs,n2,fxy(ii,:,kk))
!  enddo
!  deallocate (coefs)
!
  veca(1)=(1.d0-dx)**2*(1.d0+2.d0*dx)
  veca(2)=dx**2*(3.d0-2.d0*dx)
  veca(3)=(1.d0-dx)**2*dx*dxg
  veca(4)=(dx-1.d0)*dx**2*dxg

  vecb(1)=(1.d0-dy)**2*(1.d0+2.d0*dy)
  vecb(2)=dy**2*(3.d0-2.d0*dy)
  vecb(3)=(1.d0-dy)**2*dy*dyg
  vecb(4)=(dy-1.d0)*dy**2*dyg

  dmat(1,1)=f(ilo,jlo,kk)
  dmat(1,2)=f(ilo,jhi,kk)
  dmat(1,3)=fy(ilo,jlo,kk)
  dmat(1,4)=fy(ilo,jhi,kk)
  dmat(2,1)=f(ihi,jlo,kk)
  dmat(2,2)=f(ihi,jhi,kk)
  dmat(2,3)=fy(ihi,jlo,kk)
  dmat(2,4)=fy(ihi,jhi,kk)
  dmat(3,1)=fx(ilo,jlo,kk)
  dmat(3,2)=fx(ilo,jhi,kk)
  dmat(3,3)=fxy(ilo,jlo,kk)
  dmat(3,4)=fxy(ilo,jhi,kk)
  dmat(4,1)=fx(ihi,jlo,kk)
  dmat(4,2)=fx(ihi,jhi,kk)
  dmat(4,3)=fxy(ihi,jlo,kk)
  dmat(4,4)=fxy(ihi,jhi,kk)

  zvals(kk)=0.d0
  do ii=1,4
  do jj=1,4
    zvals(kk)=zvals(kk)+dmat(jj,ii)*vecb(ii)*veca(jj)
  enddo
  enddo
enddo

allocate (coefs(n3))
call spline(zvals,z,n3,t3,coefs)
do kk=1,nz
  call evalspline(zvals,z,t3,coefs,n3,zv(kk),fv(kk))
enddo
deallocate (coefs)

return
end subroutine spl23


program test
  use integrate_sde
  use operators
  use globals
  use basis_change
  integer(idp) :: n=200
  type(wave_fn) :: y, y1, y2
  complex(cdp) :: alpha
  y%in_basis%n=n
  y%in_basis%alpha=cmplx(0)
  allocate(y%co_eff(0:n), y2%co_eff(0:n))
  y%co_eff=cmplx(1.0d0,0.0d0)
  write(*,*) 'Enter alpha '
  read(*,*) alpha
  do j=1,y%in_basis%n

     y%co_eff(j)=alpha/sqrt(dble(j))*y%co_eff(j-1)
  end do
  y%co_eff = y%co_eff / normalisation(y)
  y1=.ad.y
  y2%co_eff=(y.ad.y)*y%co_eff
  open(unit=1, file="y1.dat")
  write(1,'(e20.8, e20.8)') y1%co_eff
  close(1)
  open(unit=1, file="y2.dat")
  write(1,'(e20.8, e20.8)') y2%co_eff
  close(1)
  write(*,*) y.ad.y,(sum(abs(y1%co_eff-y2%co_eff)))/sum(abs(y2%co_eff))
  deallocate(y%co_eff)
end program test


subroutine rpt2(ixy, imp, maxm, num_eqn, num_waves, num_aux, num_ghost,   &
                num_cells, ql, qr, aux1, aux2, aux3, asdq, bmasdq, bpasdq)
! Transverse solver for shallow water with bathymetry using an fwave solver
! Note that this solver does NOT handle dry-states
!
! (h)_t + (h*u)_x = 0
! (hu)_t + (h*u^2 + 1/2*grav*h^2)_x + (h*u*v)_y = -grav*h*(b)_x
! (hv)_t + (h*u*v)_x + (h*v^2 + 1/2*grav*h^2)_y = -grav*h*(b)_y
!
! using the f-wave algorithm and Roe's approximate Riemann solver.
!
! waves:     3
! equations: 3
!
! Conserved quantities:
!       1 depth
!       2 x_momentum
!       3 y_momentum
!
! Auxiliary fields:
!       1 bathymetry
!
! The gravitational constant grav should be in the common block cparam.
!
! See http://www.clawpack.org/riemann.html for a detailed explanation
! of the Riemann solver API.

    implicit none

    ! Input
    integer, intent(in) :: ixy, imp, maxm, num_eqn, num_waves, num_aux
    integer, intent(in) :: num_ghost, num_cells
    real(kind=8), intent(in) :: ql(num_eqn, 1 - num_ghost:maxm + num_ghost)
    real(kind=8), intent(in) :: qr(num_eqn, 1 - num_ghost:maxm + num_ghost)
    real(kind=8), intent(in) :: aux1(num_aux, 1 - num_ghost:maxm + num_ghost)
    real(kind=8), intent(in) :: aux2(num_aux, 1 - num_ghost:maxm + num_ghost)
    real(kind=8), intent(in) :: aux3(num_aux, 1 - num_ghost:maxm + num_ghost)
    real(kind=8), intent(in) :: asdq(num_eqn, 1 - num_ghost:maxm + num_ghost)

    ! Output
    real(kind=8), intent(out) :: bmasdq(num_eqn, 1 - num_ghost:maxm + num_ghost)
    real(kind=8), intent(out) :: bpasdq(num_eqn, 1 - num_ghost:maxm + num_ghost)

    ! Local
    integer :: i, k, normal_index, transverse_index
    real(kind=8) :: h_l, h_r, u_l, u_r, v_l, v_r, h_bar, h_root, u_hat, v_hat
    real(kind=8) :: dry_state_l, dry_state_r, s(3), beta(3), R(3, 3)

    ! Parameters
    real(kind=8) :: grav, dry_tolerance, sea_level
    common /cparam/ grav, dry_tolerance, sea_level

    ! Deterimine direction of solve
    if (ixy == 1) then
        normal_index = 2
        transverse_index = 3
    else
        normal_index = 3
        transverse_index = 2
    end if

    ! Primary loop over cell edges
    do i = 2 - num_ghost, num_cells + num_ghost

        ! Check for dry states - need merge here to convert to float
        dry_state_l = merge(0.d0, 1.d0, qr(1, i - 1) < dry_tolerance)
        dry_state_r = merge(0.d0, 1.d0, ql(1, i) < dry_tolerance)

        ! Extract state variables
        h_l = qr(1, i - 1) * dry_state_l
        u_l = qr(normal_index, i - 1) / qr(1, i - 1) * dry_state_l
        v_l = qr(transverse_index, i - 1) / qr(1, i - 1) * dry_state_l

        h_r = ql(1, i) * dry_state_r
        u_r = ql(normal_index, i) / ql(1, i) * dry_state_r
        v_r = ql(transverse_index, i) / ql(1, i) * dry_state_r

        ! Determine speeds for the Jacobian
        h_bar = 0.5d0 * (h_r + h_l)
        h_root = sqrt(h_r) + sqrt(h_l)
        v_hat = (v_r * sqrt(h_r)) / h_root + (v_l * sqrt(h_l)) / h_root
        u_hat = (u_r * sqrt(h_r)) / h_root + (u_l * sqrt(h_l)) / h_root

        s(1) = min(v_hat - sqrt(grav * h_bar), v_l - sqrt(grav * h_l))
        s(3) = max(v_hat + sqrt(grav * h_bar), v_r + sqrt(grav * h_r))
        s(2) = 0.5d0 * (s(1) + s(2))

        ! Determine asdq decompisition
        beta(1) = s(3) * asdq(1, i) / (s(3) - s(1))                 &
                                - asdq(transverse_index, i) / (s(3) - s(1))
        beta(2) = -s(2) * asdq(1, i) + asdq(normal_index, i)
        beta(3) = asdq(transverse_index, i) / (s(3) - s(1))         &
                                - (s(1) * asdq(1, i) / (s(3) - s(1)))

        ! Eigenvectors
        R(1, :) = [1.d0, 0.d0, 1.d0]
        R(2, :) = [s(2), 1.d0, s(2)]
        R(3, :) = [s(1), 0.d0, s(3)]

        ! Compute fluctuations
        do k = 1, num_waves
            if (s(k) < 0.d0) then
                bmasdq(1, i) = bmasdq(1, i) + s(k) * beta(k) * R(1, k)
                bmasdq(normal_index, i) = bmasdq(normal_index, i)              &
                                                + s(k) * beta(k) * R(2, k)
                bmasdq(transverse_index, i) = bmasdq(transverse_index, i)      &
                                                + s(k) * beta(k) * R(3, k)
            else
                bpasdq(1, i) = bpasdq(1, i) + s(k) * beta(k) * R(1, k)
                bpasdq(normal_index, i) = bpasdq(normal_index, i)              &
                                                + s(k) * beta(k) * R(2, k)
                bpasdq(transverse_index, i) = bpasdq(transverse_index, i)      &
                                                + s(k) * beta(k) * R(3, k)
            end if
        end do

    end do  ! End of primary loop

end subroutine rpt2


SUBROUTINE gammas(incx,mu,sig,omega)

!-------------------------------------------------------------
!
! Compute gamma elements from known analytic form of gamma
!
!-------------------------------------------------------------

USE invar
USE solvar
IMPLICIT NONE
INTEGER, INTENT(IN) :: incx
INTEGER :: l, ll, lmm, lpm, indx, fact
REAL*8, INTENT(IN) :: mu, sig, omega
REAL*8 :: alf, plm2, plm1, pl, plm1m, plm, plmp1, sh, p, clm
REAL*8, DIMENSION(0:anord) :: al, oal
REAL*8, DIMENSION(3,3) :: amat
REAL*8, DIMENSION(3,(nmom+2)) :: bmat, gmat

! Initialize the amat and bmat values
amat = 0.0
bmat = 0.0
gmat = 0.0

! Set the elements of bmat
! Elements from the balance equation
plm1 = 0.0
pl   = 1.0
DO l = 0, anord
   al = 0.0      ! Initialize
   IF (l /= 0) CALL legpoly(l,incx,mu,plm2,plm1,pl)
   al(0) = pl
   DO ll = 0, l
      IF (ll /= 0) THEN
         plm1m = oal(ll-1)
         plm   = al(ll-1)
         CALL aslegf(l,ll,incx,mu,plm1m,plm,plmp1)
         al(ll) = plmp1
      END IF
      lmm = l - ll
      lpm = l + ll
      clm = (2.0*l + 1.0)*REAL(fact(lmm))/REAL(fact(lpm))
      sh = SQRT(clm)*al(ll)*COS(ll*omega)
      ! Now have the value, can set in bmat
      indx = l*(l+1)/2 + ll + 1
      p = 1.0
      IF (ll > 0) p = 2.0
      bmat(1,indx) = p*sh
   END DO
   ! Reset values
   plm2 = plm1
   plm1 = pl
   oal = al
END DO

! Elements corresponding to incoming flux
bmat(1,nmom+1) = ey
bmat(1,nmom+2) = ex

! Elements corresponding to DD relations
bmat(2,nmom+1) = 1.0
bmat(3,nmom+2) = 1.0

! Set the elements of the inverted amat directly since it's only 3x3
alf = 1.0/(sig+2.0*ey+2.0*ex)
amat(1,1) = alf
amat(2,1) = alf*2.0
amat(3,1) = amat(2,1)
amat(1,2) = alf*ey
amat(2,2) = alf*(-sig-2.0*ex)
amat(3,2) = alf*2.0*ey
amat(1,3) = alf*ex
amat(2,3) = alf*2.0*ex
amat(3,3) = alf*(-sig-2.0*ey)

! Form gmat as the product of inverted amat on bmat
gmat = MATMUL(amat,bmat)

! Store the gmat elements
! Set the gaa from gmat, first equation, first nmom equations
gaa = gmat(1,1:nmom)
! Set gax & gay from gmat, first equation, last 2 elements
gax = gmat(1,nmom+1)
gay = gmat(1,nmom+2)
! Set gxa and gya from gmat, second & third equations, first nmom equations
gxa = gmat(2,1:nmom)
gya = gmat(3,1:nmom)
! Set gxx, gxy, gyx, gyy from gmat, bottom right 2x2 corner
gxx = gmat(2,nmom+1)
gxy = gmat(2,nmom+2)
gyx = gmat(3,nmom+1)
gyy = gmat(3,nmom+2)

RETURN
END SUBROUTINE gammas


!***********************************************************************
!                                                                      *
      REAL(KIND(0.0D0)) FUNCTION GCO (K, IR, IA, IB)
!                                                                      *
!   This routine evaluates a coefficient                               *
!                                                                      *
!                                K                                     *
!                               g   (IA,IB)                            *
!                                IR                                    *
!                                                                      *
!                                                                      *
!   Here  K  is the multipolarity, IR  is the sequence number of the   *
!   configuration, and  IA and IB are orbital sequence  numbers. See   *
!   I P Grant,  B J McKenzie,  P H Norrington,  D F  Mayers, and N C   *
!   Pyper, Computer Phys Commun 21 (1980) 207-231, Eq (7).             *
!                                                                      *
!   Call(s) to: [LIB92]: CLRX.                                         *
!                                                                      *
!   Written by Farid A Parpia, at Oxford  Last revision: 18 Dec 1992   *
!                                                                      *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  14:06:32   1/ 3/07
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE debug_C
      USE orb_C, IIQA=>IQA
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE clrx_I
      USE IQ_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: K
      INTEGER  :: IR
      INTEGER, INTENT(IN) :: IA
      INTEGER, INTENT(IN) :: IB
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: IQA, IQB
      REAL(DOUBLE) :: FAC
!-----------------------------------------------
!
         IQA = IQ (IA,IR)
         IQB = IQ (IB,IR)
!GG      IQA = IBITS(IIQA((IA - 1)/4 + 1,IR),8*MOD(IA - 1,4),8)
!GG      IQB = IBITS(IIQA((IB - 1)/4 + 1,IR),8*MOD(IB - 1,4),8)
      IF (IQA==NKJ(IA) + 1 .OR. IQB==NKJ(IB)+1) THEN
         FAC = CLRX(NAK(IA),K,NAK(IB))
         GCO = -DBLE(IQA*IQB)*FAC*FAC
      ELSE
         GCO = 0.0D00
      ENDIF

      RETURN
      END FUNCTION GCO


      subroutine nbsgam(acfnbs,adh,fxi,nchlor,noutpt,nttyo)
c
c     This subroutine calculates the log activity coefficient of the
c     chloride ion according to the NBS pH convention (e.g., Covington,
c     Bates, and Durst, 1985). The convention itself may be extended
c     outside the specified limit of 0.1 molal on the ionic strength.
c
c     Reference:
c
c       Covington, A.K., Bates, R.G., and Durst, R.A., 1985,
c       Definition of pH scales, standard reference values, measure-
c       ment of pH and related terminology (recommendations, 1984):
c       Pure and Applied Chemistry, v. 57, p. 533-542.
c
c     This subroutine is called by:
c
c       EQLIB/gpheh.f
c       EQLIBG/gcoeff.f
c
c-----------------------------------------------------------------------
c
c     Principal input:
c
c       adh    = Debye-Huckel A(gamma) parameter
c       fxi    = the ionic strength (the 2nd-order electrostatic
c                  moment function I)
c       nchlor = the species index of the chloride ion
c
c     Principal output:
c
c       acfnbs = log gamma(Cl-), according to the Bates-Guggenheim
c                convention
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer nchlor,noutpt,nttyo
c
      real*8 acfnbs,adh,fxi
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      real*8 fxisqt
c
c-----------------------------------------------------------------------
c
c     Test the species index of the chloride ion.
c
      if (nchlor .le. 0) then
        write (noutpt,1000)
        write (nttyo ,1000)
 1000   format(/' * Error - (EQLIBG/nbsgam) Have no index for the',
     $  /7x,"chloride ion. Can't use the extended NBS pH scale.")
        stop
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Evaluate the NBS expression for the molal activity coefficient
c     of the chloride ion.
c
      fxisqt = sqrt(fxi)
      acfnbs = - ( adh * fxisqt ) / ( 1.0 + ( 1.5 * fxisqt ) )
c
      end


!-----------------------------------------------------------------------------
!> Module for mapping iso-lines
!>
!>
!-----------------------------------------------------------------------------
module isolines
  use saturation_point_locators, only: iso_cross_saturation_line
  use saturation_curve, only: ISO_P, ISO_T, ISO_S, ISO_H, iso_label
  implicit none
  private
  save

  public :: isotherm, isobar, isentrope, isenthalp

contains

  !-----------------------------------------------------------------------------
  !> Map isotherm
  !>
  !> \author Morten Hammer, 2020-06
  !-----------------------------------------------------------------------------
  subroutine isotherm(T,Pmin,Pmax,z,n,pa,va,sa,ha,na)
    use thermopack_constants, only: TWOPH, SINGLEPH, VAPPH, LIQPH
    use thermopack_var, only: nc
    use eosTV, only: entropyTV, enthalpyTV, pressure
    use eos, only: specificvolume, getCriticalParam
    use thermo_utils, only: isSingleComp
    use saturation, only: safe_bubP
    use tp_solver, only: twoPhaseTPflash
    real, intent(in) :: T !< Temperature (K)
    real, intent(in) :: Pmin, Pmax !< Pressure limits (Pa)
    real, intent(in) :: z(nc) !< Composition (-)
    integer, intent(in) :: n !< Number of points
    real, intent(out) :: pa(n) !< Pressure (Pa)
    real, intent(out) :: va(n) !< Spcecific volume (m3/mol)
    real, intent(out) :: sa(n) !< Specific entropy (J/mol/K)
    real, intent(out) :: ha(n) !< Specifc enthalpy (J/mol)
    integer, intent(out) :: na !< Number of points
    ! Locals
    real :: ta(n) !< Temperature (K)
    integer :: i, i_pure, phase(n), n_vap, istart
    real :: Pbub, Y(n,nc), X(n,nc), beta(n), betaL(n)
    real :: vg, vl, sg, sl, hg, hl
    real :: tci,pci,oi,vci
    real :: tsat, vsat, psat

    na = n
    if (isSingleComp(z)) then
      i_pure = maxloc(z,dim=1)
      call getCriticalParam(i_pure,tci,pci,oi,vci)
      if (T >= tci) then
        phase = VAPPH
        call linspace(Pmin,Pmax,n,pa)
      else
        Pbub = safe_bubP(T,Z,Y)
        if (Pbub <= Pmin) then
          phase = LIQPH
          call linspace(Pmin,Pmax,n,pa)
        else if (Pbub >= Pmax) then
          phase = VAPPH
          call linspace(Pmin,Pmax,n,pa)
        else
          n_vap = ceiling(n*(Pbub - Pmin)/(Pmax-Pmin))
          if (n_vap > nint(n*0.5)) n_vap = n_vap - 1
          phase(1:n_vap) = VAPPH
          call linspace(Pmin,Pbub,n_vap,pa(1:n_vap))
          phase(n_vap+1:n) = LIQPH
          call linspace(Pmin,Pbub,n-n_vap,pa(n_vap+1:n))
        endif
        do i=1,n
          call specificvolume(T,pa(i),z,phase(i),va(i))
          call enthalpyTV(T,va(i),z,ha(i))
          call entropyTV(T,va(i),z,sa(i))
        enddo
      endif
    else
      !if (n > 15) then
      !  na = n - 2
      !else
        na = n
      !endif
      call linspace(Pmin,Pmax,na,pa)
      do i=1,na
        call twoPhaseTPflash(T,pa(i),Z,beta(i),betaL(i),phase(i),X(i,:),Y(i,:))
        if (phase(i) == SINGLEPH) phase(i) = LIQPH
        if (phase(i) == TWOPH) then
          call specificvolume(T,pa(i),y(i,:),VAPPH,vg)
          call enthalpyTV(T,vg,y(i,:),hg)
          call entropyTV(T,vg,y(i,:),sg)
          call specificvolume(T,pa(i),x(i,:),LIQPH,vl)
          call enthalpyTV(T,vl,x(i,:),hl)
          call entropyTV(T,vl,x(i,:),sl)
          va(i) = beta(i)*vg + betaL(i)*vl
          ha(i) = beta(i)*hg + betaL(i)*hl
          sa(i) = beta(i)*sg + betaL(i)*sl
        else
          call specificvolume(T,pa(i),z,phase(i),va(i))
          call enthalpyTV(T,va(i),z,ha(i))
          call entropyTV(T,va(i),z,sa(i))
        endif
      enddo
      if (na < n) then
        ta = T
        istart = 1
        if (phase_transition(ta,pa,phase,beta,betaL,Z,X,Y,n,na,istart,ISO_T,T,tsat,vsat)) then
          call enthalpyTV(T,vsat,z,hg)
          call entropyTV(T,vsat,z,sg)
          psat = pressure(T,vsat,z)
          call add_point(istart,ta,pa,va,sa,ha,n,na,t,psat,vsat,sg,hg)
          istart = istart + 1
        endif
        if (phase_transition(ta,pa,phase,beta,betaL,Z,X,Y,n,na,istart,ISO_T,T,tsat,vsat)) then
          call enthalpyTV(T,vsat,z,hg)
          call entropyTV(T,vsat,z,sg)
          psat = pressure(T,vsat,z)
          call add_point(istart,ta,pa,va,sa,ha,n,na,t,psat,vsat,sg,hg)
        endif
      endif
    endif
  end subroutine isotherm

  !-----------------------------------------------------------------------------
  !> Map isobar
  !>
  !> \author Morten Hammer, 2020-06
  !-----------------------------------------------------------------------------
  subroutine isobar(P,Tmin,Tmax,z,n,ta,va,sa,ha,na)
    use thermopack_constants, only: TWOPH, SINGLEPH, VAPPH, LIQPH
    use thermopack_var, only: nc
    use eosTV, only: entropyTV, enthalpyTV
    use eos, only: specificvolume, getCriticalParam
    use thermo_utils, only: isSingleComp
    use saturation, only: safe_bubT
    use tp_solver, only: twoPhaseTPflash
    real, intent(in) :: P !< Pressure (Pa)
    real, intent(in) :: Tmin, Tmax !< Temperature limits (K)
    real, intent(in) :: z(nc) !< Composition (-)
    integer, intent(in) :: n !< Number of points
    real, intent(out) :: ta(n) !< Temperature (K)
    real, intent(out) :: va(n) !< Spcecific volume (m3/mol)
    real, intent(out) :: sa(n) !< Specific entropy (J/mol/K)
    real, intent(out) :: ha(n) !< Specifc enthalpy (J/mol)
    integer, intent(out) :: na !< Number of points
    ! Locals
    integer :: i, i_pure, phase(n), n_liq
    real :: Tbub, Y(nc), X(nc), beta, betaL
    real :: vg, vl, sg, sl, hg, hl
    real :: tci,pci,oi,vci

    na = n
    if (isSingleComp(z)) then
      i_pure = maxloc(z,dim=1)
      call getCriticalParam(i_pure,tci,pci,oi,vci)
      if (P >= pci) then
        phase = LIQPH
        call linspace(Tmin,Tmax,n,ta)
      else
        Tbub = safe_bubT(P,Z,Y)
        if (Tbub <= Tmin) then
          phase = VAPPH
          call linspace(Tmin,Tmax,n,ta)
        else if (Tbub >= Tmax) then
          phase = LIQPH
          call linspace(Tmin,Tmax,n,ta)
        else
          n_liq = ceiling(n*(Tbub - Tmin)/(Tmax-Tmin))
          if (n_liq > nint(n*0.5)) n_liq = n_liq - 1
          phase(1:n_liq) = LIQPH
          call linspace(Tmin,Tbub,n_liq,ta(1:n_liq))
          phase(n_liq+1:n) = VAPPH
          call linspace(Tmin,Tbub,n-n_liq,ta(n_liq+1:n))
        endif
        do i=1,n
          call specificvolume(ta(i),P,z,phase(i),va(i))
          call enthalpyTV(ta(i),va(i),z,ha(i))
          call entropyTV(ta(i),va(i),z,sa(i))
        enddo
      endif
    else
      call linspace(Tmin,Tmax,n,ta)
      do i=1,n
        call twoPhaseTPflash(ta(i),P,Z,beta,betaL,phase(i),X,Y)
        if (phase(i) == SINGLEPH) phase(i) = LIQPH
        if (phase(i) == TWOPH) then
          call specificvolume(ta(i),P,y,VAPPH,vg)
          call enthalpyTV(ta(i),vg,y,hg)
          call entropyTV(ta(i),vg,y,sg)
          call specificvolume(ta(i),P,x,LIQPH,vl)
          call enthalpyTV(ta(i),vl,x,hl)
          call entropyTV(ta(i),vl,x,sl)
          va(i) = beta*vg + betaL*vl
          ha(i) = beta*hg + betaL*hl
          sa(i) = beta*sg + betaL*sl
        else
          call specificvolume(ta(i),P,z,phase(i),va(i))
          call enthalpyTV(ta(i),va(i),z,ha(i))
          call entropyTV(ta(i),va(i),z,sa(i))
        endif
      enddo
    endif
  end subroutine isobar

  !-----------------------------------------------------------------------------
  !> Map isoenthalp
  !>
  !> \author Morten Hammer, 2020-06
  !-----------------------------------------------------------------------------
  subroutine isenthalp(h,Pmin,Pmax,Tmin,Tmax,z,n,pa,va,sa,ta,na)
    use thermopack_constants, only: TWOPH, SINGLEPH, VAPPH, LIQPH, &
         tpTmin, tpTmax
    use thermopack_var, only: nc
    use eosTV, only: entropyTV
    use eos, only: specificvolume
    use ph_solver, only: twoPhasePHflash
    real, intent(in) :: h !< Specific enthalpy (J/mol)
    real, intent(in) :: Pmin, Pmax !< Pressure limits (Pa)
    real, intent(in) :: Tmin, Tmax !< Temperature limits (K)
    real, intent(in) :: z(nc) !< Composition (-)
    integer, intent(in) :: n !< Number of points
    real, intent(out) :: pa(n) !< Temperature (Pa)
    real, intent(out) :: va(n) !< Spcecific volume (m3/mol)
    real, intent(out) :: sa(n) !< Specific entropy (J/mol/K)
    real, intent(out) :: ta(n) !< Temperature (K)
    integer, intent(out) :: na !< Number of points
    ! Locals
    integer :: i, phase, ierr(n)
    real :: Y(nc), X(nc), beta, betaL
    real :: vg, vl, sg, sl
    real :: tmax_old, tmin_old
    tmax_old = tpTmax
    tmin_old = tpTmin
    tpTmax = tmax
    tpTmin = tmin

    call linspace(Pmin,Pmax,n,pa)
    na = n
    ta(1) = 0.5*(tmax + tmin)
    do i=1,n
      if (i > 1) ta(i) = ta(i-1)
      call twoPhasePHflash(ta(i),pa(i),Z,beta,betaL,X,Y,h,phase,ierr(i))
      if (ierr(i) == 0 .or. ierr(i) == -1) then
        ierr(i) = 0
        if (phase == SINGLEPH) phase = LIQPH
        if (phase == TWOPH) then
          call specificvolume(ta(i),pa(i),y,VAPPH,vg)
          call entropyTV(ta(i),vg,y,sg)
          call specificvolume(ta(i),pa(i),x,LIQPH,vl)
          call entropyTV(ta(i),vl,x,sl)
          va(i) = beta*vg + betaL*vl
          sa(i) = beta*sg + betaL*sl
        else
          call specificvolume(ta(i),pa(i),z,phase,va(i))
          call entropyTV(ta(i),va(i),z,sa(i))
        endif
      else
        ierr(i) = 1
      endif
    enddo
    if (sum(ierr) > 0) then
      na = 0
      do i=1,n
        if (ierr(i) == 0) then
          na = na + 1
          ta(na) = ta(i)
          pa(na) = pa(i)
          va(na) = va(i)
          sa(na) = sa(i)
        endif
      enddo
    endif
    tpTmax = tmax_old
    tpTmin = tmin_old

  end subroutine isenthalp

  !-----------------------------------------------------------------------------
  !> Map isoentrope
  !>
  !> \author Morten Hammer, 2020-06
  !-----------------------------------------------------------------------------
  subroutine isentrope(s,Pmin,Pmax,Tmin,Tmax,z,n,pa,va,ha,ta,na)
    use thermopack_constants, only: TWOPH, SINGLEPH, VAPPH, LIQPH, &
         tpTmin, tpTmax
    use thermopack_var, only: nc
    use eosTV, only: enthalpyTV
    use eos, only: specificvolume
    use ps_solver, only: twoPhasePSflash
    real, intent(in) :: s !< Specific entropy (J/mol/K)
    real, intent(in) :: Pmin, Pmax !< Pressure limits (Pa)
    real, intent(in) :: Tmin, Tmax !< Temperature limits (K)
    real, intent(in) :: z(nc) !< Composition (-)
    integer, intent(in) :: n !< Number of points
    real, intent(out) :: pa(n) !< Pressure (Pa)
    real, intent(out) :: va(n) !< Spcecific volume (m3/mol)
    real, intent(out) :: ha(n) !< Specific enthalpy (J/mol)
    real, intent(out) :: ta(n) !< Temperature (K)
    integer, intent(out) :: na !< Number of points
    ! Locals
    integer :: i, phase, ierr(n)
    real :: Y(nc), X(nc), beta, betaL
    real :: vg, vl, hg, hl
    real :: tmax_old, tmin_old
    tmax_old = tpTmax
    tmin_old = tpTmin
    tpTmax = tmax
    tpTmin = tmin

    call linspace(Pmin,Pmax,n,pa)
    na = n
    ta(1) = 0.5*(tmax + tmin)
    do i=1,n
      if (i > 1) ta(i) = ta(i-1)
      call twoPhasePSflash(ta(i),pa(i),Z,beta,betaL,X,Y,s,phase,ierr(i))
      if (ierr(i) == 0 .or. ierr(i) == -1) then
        ierr(i) = 0
        if (phase == SINGLEPH) phase = LIQPH
        if (phase == TWOPH) then
          call specificvolume(ta(i),pa(i),y,VAPPH,vg)
          call enthalpyTV(ta(i),vg,y,hg)
          call specificvolume(ta(i),pa(i),x,LIQPH,vl)
          call enthalpyTV(ta(i),vl,x,hl)
          va(i) = beta*vg + betaL*vl
          ha(i) = beta*hg + betaL*hl
        else
          call specificvolume(ta(i),pa(i),z,phase,va(i))
          call enthalpyTV(ta(i),va(i),z,ha(i))
        endif
      else
        ierr(i) = 1
      endif
    enddo
    if (sum(ierr) > 0) then
      na = 0
      do i=1,n
        if (ierr(i) == 0) then
          na = na + 1
          ta(na) = ta(i)
          pa(na) = pa(i)
          va(na) = va(i)
          ha(na) = ha(i)
        endif
      enddo
    endif
    tpTmax = tmax_old
    tpTmin = tmin_old

  end subroutine isentrope

  subroutine linspace(xmin,xmax,n,x)
    real, intent(in) :: xmin, xmax !< Limits
    integer, intent(in) :: n !< Number of points
    real, intent(out) :: x(n) !< Equidistant points
    ! Locals
    integer :: i
    real :: dx
    dx = (xmax-xmin)/(n-1)
    do i=1,n
      x(i) = xmin + dx*(i-1)
    enddo
  end subroutine linspace

  subroutine add_point(istart,ta,pa,va,sa,ha,n,na,t,p,v,s,h)
    integer, intent(in) :: istart !< Add point at index
    integer, intent(in) :: n !< Maximum of points
    integer, intent(inout) :: na !< Number of points
    real, intent(inout) :: ta(n),pa(n),va(n),sa(n),ha(n) !< Output variables
    real, intent(in) :: t,p,v,s,h  !<
    ! Locals
    integer :: i
    if (na < n) then
      na = na + 1
      do i=na,istart+1,-1
        ta(i) = ta(i-1)
        pa(i) = pa(i-1)
        va(i) = va(i-1)
        ha(i) = ha(i-1)
        sa(i) = sa(i-1)
      enddo
      ta(istart) = t
      pa(istart) = p
      va(istart) = v
      ha(istart) = h
      sa(istart) = s
    endif
  end subroutine add_point

  function phase_transition(ta,pa,phase,beta,betaL,Z,X,Y,n,na,istart,&
       iso_variable,iso_prop,tsat,vsat) result(hasTransition)
    use eos, only: specificvolume
    use thermopack_constants, only: TWOPH
    use thermopack_var, only: nc
    real, intent(in) :: ta(n),pa(n),beta(n),betaL(n)
    real, intent(in) :: Z(nc),X(n,nc),Y(n,nc),iso_prop
    integer, intent(in) :: n,na,iso_variable,phase(n)
    integer, intent(inout) :: istart
    real, intent(out) :: tsat, vsat
    logical :: hasTransition
    ! Locals
    integer :: ierr, i, ph
    real :: psat,ysat(nc),xsat(nc),bsat,tsingle,psingle
    hasTransition = .false.
    do i=2,na
      if (phase(i) == TWOPH .and. phase(i-1) /= TWOPH) then
        if (phase(i) == TWOPH) then
          istart = i
          tsingle = ta(i-1)
          psingle = pa(i-1)
        else
          istart = i-1
          tsingle = ta(i)
          psingle = pa(i)
        endif
        tsat = ta(istart)
        psat = pa(istart)
        ysat = Y(istart,:)
        xsat = X(istart,:)
        bsat = beta(istart)
        hasTransition = .true.
        exit
      endif
    enddo
    if (hasTransition) then
      ! Extrapolate two-phase point to saturtaion line
      call iso_cross_saturation_line(tsingle,psingle,tsat,psat,Xsat,Ysat,Z,bsat,&
           iso_prop,iso_label(iso_variable),ph,ierr)
      if (ierr == 0) then
        call specificvolume(tsat,psat,Z,ph,vsat)
      else
        hasTransition = .false.
      endif
    else
      istart = na + 1
    endif
  end function phase_transition
end module isolines


C    @(#)asvsec.f	20.3 2/13/96
      subroutine asvsec (a,s,v,y)
C
C     Subroutine to calculate the line flow and voltage conditions at
C       the far end of a series line section from conditions at its
C       near end.
C     A is for complex amps, S for complex power, V for complex voltage.
C     Y is a two-port admittance matrix between neighboring buses.
C     Side 1 is the near end.  Side 2 is the far end.
C
      complex a(2),s(2),v(2),y(2,2)
C
      v(2)=(a(1)-y(1,1)*v(1))/y(1,2)
      a(2)=y(2,1)*v(1)+y(2,2)*v(2)
      s(2)=v(2)*conjg(a(2))
      return
      end


      subroutine dfv_m(r,y,dy,nv,n,rn,ecomp,vr,
     &           eunit,b,allp1)
c     =============
      implicit none
c
c------ compute derivatives
c
c
      complex*16 ecomp
c
      real*8 r
      integer nv,n
      real*8 y(nv),dy(nv),rn,vr(n)
      real*8 eunit
      real*8 b, allp1
c
      real*8 s1or,s1or2,ereal,eimag,facr,faci
      real*8 v,s2vmei,s2vmer,r1,frelr,freli
      real*8 den,escale
c
      s1or=1.0d0/r
      s1or2=s1or*s1or
      ereal=dreal(ecomp)
      eimag=dimag(ecomp)
c
      r1=r-rn
      v=vr(1)*r1+vr(2)
      if(n.ge.3) then
	v=v/(1.d0+vr(3)*r1*r1)
	if(n.eq.4) v=v+vr(n)
      endif
c
      s2vmer=eunit*(v*s1or-ereal)
      frelr=1.0d0-b*s2vmer
      if(nv.eq.2) then
	if(b.eq.0.d0) then
	if(y(1).eq.0.d0.and.y(2).eq.0.d0) then
	  dy(1)=frelr
	  dy(2)=allp1*s1or2/frelr+s2vmer
        else
          facr=allp1*s1or2/frelr+s2vmer
          dy(1)=frelr*y(2)+s1or*y(1)
          dy(2)=facr*y(1)-y(2)*s1or
	endif
        else
	  escale=0.5d0*eunit
	  facr=allp1*s1or
          s2vmer=escale*(v*s1or-ereal)/b
	if(y(1).eq.0.d0.and.y(2).eq.0.d0) then
	  dy(1)=-s2vmer+2.d0*b
	  dy(2)=facr*facr-s2vmer*(s2vmer-2.d0*b)
	else
          dy(1)=(-s2vmer+2.d0*b)*y(2)-facr*y(1)
          dy(2)=s2vmer*y(1)+facr*y(2)
	endif
	endif
      else
      s2vmei=       -eunit*eimag
      freli=     -b*s2vmei
      den=allp1/(frelr*frelr+freli*freli)
      den=den*s1or2
      facr=+den*frelr+s2vmer
      faci=-den*freli+s2vmei
      dy(1)=frelr*y(3)-freli*y(4)+s1or*y(1)
      dy(2)=freli*y(3)+frelr*y(4)+s1or*y(2)
      dy(3)=facr*y(1)-faci*y(2)-y(3)*s1or
      dy(4)=faci*y(1)+facr*y(2)-y(4)*s1or
      endif
c
      return
      end


      recursive subroutine pardtc(tx,nx,ty,ny,c,kx,ky,nux,nuy,
     *   newc,ier)
      implicit none
c  subroutine pardtc takes the knots and coefficients of a bivariate
c  spline, and returns the coefficients for a new bivariate spline that
c  evaluates the partial derivative (order nux, nuy) of the original
c  spline.
c
c  calling sequence:
c     call pardtc(tx,nx,ty,ny,c,kx,ky,nux,nuy,newc,ier)
c
c  input parameters:
c   tx    : real array, length nx, which contains the position of the
c           knots in the x-direction.
c   nx    : integer, giving the total number of knots in the x-direction
c           (hidden)
c   ty    : real array, length ny, which contains the position of the
c           knots in the y-direction.
c   ny    : integer, giving the total number of knots in the y-direction
c           (hidden)
c   c     : real array, length (nx-kx-1)*(ny-ky-1), which contains the
c           b-spline coefficients.
c   kx,ky : integer values, giving the degrees of the spline.
c   nux   : integer values, specifying the order of the partial
c   nuy     derivative. 0<=nux<kx, 0<=nuy<ky.
c
c  output parameters:
c   newc  : real array containing the coefficients of the derivative.
c           the dimension is (nx-nux-kx-1)*(ny-nuy-ky-1).
c   ier   : integer error flag
c    ier=0 : normal return
c    ier=10: invalid input data (see restrictions)
c
c  restrictions:
c   0 <= nux < kx, 0 <= nuy < kyc
c
c  other subroutines required:
c    none
c
c  references :
c   de boor c  : on calculating with b-splines, j. approximation theory
c                6 (1972) 50-62.
c   dierckx p. : curve and surface fitting with splines, monographs on
c                numerical analysis, oxford university press, 1993.
c
c  based on the subroutine "parder" by Paul Dierckx.
c
c  author :
c    Cong Ma
c    Department of Mathematics and Applied Mathematics, U. of Cape Town
c    Cross Campus Road, Rondebosch 7700, Cape Town, South Africa.
c    e-mail : cong.ma@uct.ac.za
c
c  latest update : may 2019
c
c  ..scalar arguments..
      integer nx,ny,kx,ky,nux,nuy,ier, nc
c  ..array arguments..
      real*8 tx(nx),ty(ny),c((nx-kx-1)*(ny-ky-1)),
     * newc((nx-kx-1)*(ny-ky-1))
c  ..local scalars..
      integer i,j,kx1,ky1,lx,ly,l1,l2,m,m0,m1,
     * nkx1,nky1,nxx,nyy,newkx,newky
      real*8 ak,fac
c  ..
c  before starting computations a data check is made. if the input data
c  are invalid control is immediately repassed to the calling program.
      ier = 10
      if(nux.lt.0 .or. nux.ge.kx) go to 400
      if(nuy.lt.0 .or. nuy.ge.ky) go to 400
      kx1 = kx+1
      ky1 = ky+1
      nkx1 = nx-kx1
      nky1 = ny-ky1
      nc = nkx1*nky1
      ier = 0
      nxx = nkx1
      nyy = nky1
      newkx = kx
      newky = ky
c  the partial derivative of order (nux,nuy) of a bivariate spline of
c  degrees kx,ky is a bivariate spline of degrees kx-nux,ky-nuy.
c  we calculate the b-spline coefficients of this spline
c  that is to say newkx = kx - nux, newky = ky - nuy
      do 70 i=1,nc
        newc(i) = c(i)
  70  continue
      if(nux.eq.0) go to 200
      lx = 1
      do 100 j=1,nux
        ak = newkx
        nxx = nxx-1
        l1 = lx
        m0 = 1
        do 90 i=1,nxx
          l1 = l1+1
          l2 = l1+newkx
          fac = tx(l2)-tx(l1)
          if(fac.le.0.) go to 90
          do 80 m=1,nyy
            m1 = m0+nyy
            newc(m0) = (newc(m1)-newc(m0))*ak/fac
            m0  = m0+1
  80      continue
  90    continue
        lx = lx+1
        newkx = newkx-1
 100  continue
 200  if(nuy.eq.0) go to 400
c orig: if(nuy.eq.0) go to 300
      ly = 1
      do 230 j=1,nuy
        ak = newky
        nyy = nyy-1
        l1 = ly
        do 220 i=1,nyy
          l1 = l1+1
          l2 = l1+newky
          fac = ty(l2)-ty(l1)
          if(fac.le.0.) go to 220
          m0 = i
          do 210 m=1,nxx
            m1 = m0+1
            newc(m0) = (newc(m1)-newc(m0))*ak/fac
            m0  = m0+nky1
 210      continue
 220    continue
        ly = ly+1
        newky = newky-1
 230  continue
      m0 = nyy
      m1 = nky1
      do 250 m=2,nxx
        do 240 i=1,nyy
          m0 = m0+1
          m1 = m1+1
          newc(m0) = newc(m1)
 240    continue
        m1 = m1+nuy
 250  continue
c300  iwx = 1+nxx*nyy
c     iwy = iwx+mx*(kx1-nux)
c
c from parder.f:
c     call fpbisp(tx(nux+1),nx-2*nux,ty(nuy+1),ny-2*nuy,newc,newkx,newky,
c    * x,mx,y,my,z,newc(iwx),newc(iwy),iwrk(1),iwrk(mx+1))
c
c from bispev.f:
c     call fpbisp(tx,       nx,      ty,       ny,      c,   kx,   ky,
c    * x,mx,y,my,z,wrk(1),   wrk(iw),  iwrk(1),iwrk(mx+1))
c
c from fpbisp.f:
c          fpbisp(tx,       nx,      ty,       ny,      c,   kx,   ky,
c    * x,mx,y,my,z,wx,       wy,       lx,     ly)
 400  return
      end


C
C**************************  NUDLOCATE *********************************
C
C  locate the nudging observation points within our grid.
C
C***********************************************************************
C
      SUBROUTINE NUDLOCATE(NT,NUDN,TETRA,NUDTET,
     1                     NUDX,NUDY,NUDZ,X,Y,Z,VOLU)
C
      IMPLICIT NONE
      INTEGER  I,L,TK
      INTEGER  NT,NUDN
      INTEGER  IV(0:3)
      INTEGER  TETRA(5,*),NUDTET(*)
      REAL*8   PHI01_1,PHI01_2,PHI01_3,PHI01_4
      REAL*8   DEN,XX,YY,ZZ,F1,F2,F3,F4
      REAL*8   XXP(0:3),YYP(0:3),ZZP(0:3),XXS(3),YYS(3),ZZS(3)
      REAL*8   A(3,3),XL(3)
      REAL*8   NUDX(*),NUDY(*),NUDZ(*),X(*),Y(*),Z(*),VOLU(*)
      INCLUDE 'IOUNITS.H'
C
C  define the P1 step-wise function on the tetrahedra
C  (0,0,0) (1,0,0) (0,1,0) (0,0,1)
C
      PHI01_1(XX,YY,ZZ) = 1.0D0 - XX - YY - ZZ
      PHI01_2(XX,YY,ZZ) = XX
      PHI01_3(XX,YY,ZZ) = YY
      PHI01_4(XX,YY,ZZ) = ZZ
C
      DO L=1,NUDN
         NUDTET(L)=0
         DO TK=1,NT
            DO I=0,3
               IV(I)=TETRA(I+1,TK)
            END DO
            DO I=0,3
               XXP(I)=X(IV(I))
               YYP(I)=Y(IV(I))
               ZZP(I)=Z(IV(I))
            END DO
C
C  compute coordinates of tetrahedra TK relative to node (0,0,0)
C  and the determinant DEN
C
            DO I=1,3
               XXS(I)=XXP(I) - XXP(0)
               YYS(I)=YYP(I) - YYP(0)
               ZZS(I)=ZZP(I) - ZZP(0)
            END DO
            DEN=6.0D0 * ABS(VOLU(TK))
C
C  matrix of coordinate transformation from local to isoparametric
C
            A(1,1) =  (YYS(2)*ZZS(3) - ZZS(2)*YYS(3)) / DEN
            A(1,2) = -(XXS(2)*ZZS(3) - ZZS(2)*XXS(3)) / DEN
            A(1,3) =  (XXS(2)*YYS(3) - YYS(2)*XXS(3)) / DEN
            A(2,1) = -(YYS(1)*ZZS(3) - ZZS(1)*YYS(3)) / DEN
            A(2,2) =  (XXS(1)*ZZS(3) - ZZS(1)*XXS(3)) / DEN
            A(2,3) = -(XXS(1)*YYS(3) - YYS(1)*XXS(3)) / DEN
            A(3,1) =  (YYS(1)*ZZS(2) - ZZS(1)*YYS(2)) / DEN
            A(3,2) = -(XXS(1)*ZZS(2) - ZZS(1)*XXS(2)) / DEN
            A(3,3) =  (XXS(1)*YYS(2) - YYS(1)*XXS(2)) / DEN
C
C  determine if the observation point L lies within the tetrehedra TK.
C  As soon as we locate the tetrahedra we proceed to the next
C  observation point. If no tetrahedra is found, terminate with error.
C
            XL(1)=NUDX(L) - XXP(0)
            XL(2)=NUDY(L) - YYP(0)
            XL(3)=NUDZ(L) - ZZP(0)
            XX=0.0D0
            YY=0.0D0
            ZZ=0.0D0
            DO I=1,3
               XX=XX + A(1,I)*XL(I)
               YY=YY + A(2,I)*XL(I)
               ZZ=ZZ + A(3,I)*XL(I)
            END DO
            F1=PHI01_1(XX,YY,ZZ)
            F2=PHI01_2(XX,YY,ZZ)
            F3=PHI01_3(XX,YY,ZZ)
            F4=PHI01_4(XX,YY,ZZ)
            IF (F1 .GE. 0.0D0 .AND. F2 .GE. 0.0D0 .AND.
     1          F3 .GE. 0.0D0 .AND. F4 .GE. 0.0D0) THEN
               NUDTET(L)=TK
               GO TO 100
            END IF
         END DO
         WRITE(IOUT2,1000) L,NUDX(L),NUDY(L),NUDZ(L)
         CALL CLOSIO
         STOP
  100    CONTINUE
      END DO
C
      RETURN
 1000 FORMAT(/,' ERROR IN SUBROUTINE NUDLOCATE: OBSERVATION POINT ',I5,
     1       /,' WITH COORDINATES  (',3(1PE12.4),' )  COULD NOT BE',
     2       /,' LOCATED WITHIN THE DOMAIN')
      END


!==========================================================================
elemental subroutine gsw_enthalpy_second_derivatives_ct_exact (sa, ct, p, &
                                                 h_sa_sa, h_sa_ct, h_ct_ct)
!==========================================================================
!
!  Calculates three second-order derivatives of specific enthalpy (h).
!  Note that this function uses the full Gibbs function.
!
!  sa  =  Absolute Salinity                                        [ g/kg ]
!  ct  =  Conservative Temperature (ITS-90)                       [ deg C ]
!  p   =  sea pressure                                             [ dbar ]
!         ( i.e. absolute pressure - 10.1325 dbar )
!
!  h_sa_sa  =  The second derivative of specific enthalpy with respect to
!              Absolute Salinity at constant ct & p.    [ J/(kg (g/kg)^2) ]
!  h_sa_ct  =  The second derivative of specific enthalpy with respect to
!              sa and ct at constant p.                  [ J/(kg K(g/kg)) ]
!  h_ct_ct  =  The second derivative of specific enthalpy with respect to
!              ct at constant sa and p.                      [ J/(kg K^2) ]
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_gibbs, gsw_pt_from_ct, gsw_pt_from_t

use gsw_mod_teos10_constants, only : gsw_cp0, gsw_t0

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, ct, p
real (r8), intent(out), optional :: h_sa_sa, h_sa_ct, h_ct_ct

real (r8) :: factor, gsa_pt0, gsat_pt0, gsat, part_b, pt0, h_ct_ct_val
real (r8) :: rec_abs_pt0, rec_gtt_pt0, rec_gtt, t, temp_ratio
real (r8) :: gsasa, gsasa_pt0

integer, parameter :: n0=0, n1=1, n2=2
real (r8), parameter :: pr0 = 0.0_r8, sa_small = 1e-100_r8

pt0 = gsw_pt_from_ct(sa,ct)
rec_abs_pt0 = 1.0_r8/(gsw_t0 + pt0)
t = gsw_pt_from_t(sa,pt0,pr0,p)
temp_ratio = (gsw_t0 + t)*rec_abs_pt0

rec_gtt_pt0 = 1.0_r8/gsw_gibbs(n0,n2,n0,sa,pt0,pr0)
rec_gtt = 1.0_r8/gsw_gibbs(n0,n2,n0,sa,t,p)

! h_ct_ct is naturally well-behaved as sa approaches zero.
h_ct_ct_val = gsw_cp0*gsw_cp0* &
    (temp_ratio*rec_gtt_pt0 - rec_gtt)*(rec_abs_pt0*rec_abs_pt0)

if (present(h_ct_ct)) h_ct_ct = h_ct_ct_val

if (.not. present(h_sa_sa) .and. .not. present(h_sa_ct)) return

gsat_pt0 = gsw_gibbs(n1,n1,n0,sa,pt0,pr0)
gsat = gsw_gibbs(n1,n1,n0,sa,t,p)
gsa_pt0 = gsw_gibbs(n1,n0,n0,sa,pt0,pr0)

part_b = (temp_ratio*gsat_pt0*rec_gtt_pt0 - gsat*rec_gtt)*rec_abs_pt0
factor = gsa_pt0/gsw_cp0

if (present(h_sa_sa)) then

    gsasa = gsw_gibbs(n2,n0,n0,sa,t,p)
    gsasa_pt0 = gsw_gibbs(n2,n0,n0,sa,pt0,pr0)

    ! h_sa_sa has a singularity at sa = 0, and blows up as sa approaches zero.
    h_sa_sa = gsasa - temp_ratio*gsasa_pt0  &
        + temp_ratio*gsat_pt0*gsat_pt0*rec_gtt_pt0  &
        - gsat*gsat*rec_gtt  &
        - 2.0_r8*gsa_pt0*part_b + (factor*factor)*h_ct_ct_val

end if
if (.not. present(h_sa_ct)) return

! h_sa_ct should not blow up as sa approaches zero.  The following lines
! of code ensure that the h_sa_ct output of this function does not blow
! up in this limit.  That is, when sa < 1e-100 g/kg, we force the h_sa_ct
! output to be the same as if sa = 1e-100 g/kg.
if (sa .lt. sa_small) then
    rec_gtt_pt0 = 1.0_r8/gsw_gibbs(n0,n2,n0,sa_small,pt0,pr0)
    rec_gtt = 1.0_r8/gsw_gibbs(n0,n2,n0,sa_small,t,p)
    gsat_pt0 = gsw_gibbs(n1,n1,n0,sa_small,pt0,pr0)
    gsat = gsw_gibbs(n1,n1,n0,sa_small,t,p)
    gsa_pt0 = gsw_gibbs(n1,n0,n0,sa_small,pt0,pr0)
    part_b = (temp_ratio*gsat_pt0*rec_gtt_pt0 - gsat*rec_gtt)*rec_abs_pt0
    factor = gsa_pt0/gsw_cp0
end if

h_sa_ct  = gsw_cp0*part_b - factor*h_ct_ct_val

return
end subroutine

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


*
*
      SUBROUTINE PDGSEPCHK( IBTYPE, MS, NV, A, IA, JA, DESCA, B, IB, JB,
     $                      DESCB, THRESH, Q, IQ, JQ, DESCQ, C, IC, JC,
     $                      DESCC, W, WORK, LWORK, TSTNRM, RESULT )
*
*  -- ScaLAPACK routine (version 1.7) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 15, 1997
*
*     .. Scalar Arguments ..
      INTEGER            IA, IB, IBTYPE, IC, IQ, JA, JB, JC, JQ, LWORK,
     $                   MS, NV, RESULT
      DOUBLE PRECISION   THRESH, TSTNRM
*     ..
*     .. Array Arguments ..
*
      INTEGER            DESCA( * ), DESCB( * ), DESCC( * ), DESCQ( * )
      DOUBLE PRECISION   A( * ), B( * ), C( * ), Q( * ), W( * ),
     $                   WORK( * )
*     ..
*
*
*  Purpose
*  =======
*
*  PDGSEPCHK checks a decomposition of the form
*
*     A Q   =  B Q D or
*     A B Q =  Q D or
*     B A Q =  Q D
*
*  where A is a symmetric matrix, B is
*  symmetric positive definite, Q is orthogonal, and D is diagonal.
*
*  One of the following test ratios is computed:
*
*  IBTYPE = 1:  TSTNRM = | A Q - B Q D | / ( |A| |Q| n ulp )
*
*  IBTYPE = 2:  TSTNRM = | A B Q - Q D | / ( |A| |Q| n ulp )
*
*  IBTYPE = 3:  TSTNRM = | B A Q - Q D | / ( |A| |Q| n ulp )
*
*
*  Notes
*  =====
*
*
*  Each global data object is described by an associated description
*  vector.  This vector stores the information required to establish
*  the mapping between an object element and its corresponding process
*  and memory location.
*
*  Let A be a generic term for any 2D block cyclicly distributed array.
*  Such a global array has an associated description vector DESCA.
*  In the following comments, the character _ should be read as
*  "of the global array".
*
*  NOTATION        STORED IN      EXPLANATION
*  --------------- -------------- --------------------------------------
*  DTYPE_A(global) DESCA( DTYPE_ )The descriptor type.  In this case,
*                                 DTYPE_A = 1.
*  CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
*                                 the BLACS process grid A is distribu-
*                                 ted over. The context itself is glo-
*                                 bal, but the handle (the integer
*                                 value) may vary.
*  M_A    (global) DESCA( M_ )    The number of rows in the global
*                                 array A.
*  N_A    (global) DESCA( N_ )    The number of columns in the global
*                                 array A.
*  MB_A   (global) DESCA( MB_ )   The blocking factor used to distribute
*                                 the rows of the array.
*  NB_A   (global) DESCA( NB_ )   The blocking factor used to distribute
*                                 the columns of the array.
*  RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
*                                 row of the array A is distributed.
*  CSRC_A (global) DESCA( CSRC_ ) The process column over which the
*                                 first column of the array A is
*                                 distributed.
*  LLD_A  (local)  DESCA( LLD_ )  The leading dimension of the local
*                                 array.  LLD_A >= MAX(1,LOCr(M_A)).
*
*  Let K be the number of rows or columns of a distributed matrix,
*  and assume that its process grid has dimension p x q.
*  LOCr( K ) denotes the number of elements of K that a process
*  would receive if K were distributed over the p processes of its
*  process column.
*  Similarly, LOCc( K ) denotes the number of elements of K that a
*  process would receive if K were distributed over the q processes of
*  its process row.
*  The values of LOCr() and LOCc() may be determined via a call to the
*  ScaLAPACK tool function, NUMROC:
*          LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
*          LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
*  An upper bound for these quantities may be computed by:
*          LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
*          LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
*
*
*  Arguments
*  =========
*
*     MP = number of local rows in A, B and Q
*     MQ = number of local columns in A
*     NQ = number of local columns in B and Q
*
*  IBTYPE   (input) INTEGER
*          The form of the symmetric generalized eigenproblem.
*          = 1:  A*Q = (lambda)*B*Q
*          = 2:  A*B*Q = (lambda)*Q
*          = 3:  B*A*Q = (lambda)*Q
*
*  MS      (global input) INTEGER
*          Matrix size.
*          The number of global rows in A, B, C and Q
*          Also, the number of columns in A
*
*  NV      (global input) INTEGER
*          Number of eigenvectors
*          The number of global columns in C and Q.
*
*  A       (local input) REAL pointer to an
*          array in local memory of dimension (LLD_A, LOCc(JA+N-1)).
*          This array contains the local pieces of the M-by-N
*          distributed test matrix A
*
*  IA      (global input) INTEGER
*          A's global row index, which points to the beginning of the
*          submatrix which is to be operated on.
*
*  JA      (global input) INTEGER
*          A's global column index, which points to the beginning of
*          the submatrix which is to be operated on.
*
*  DESCA   (global and local input) INTEGER array of dimension 8
*          The array descriptor for the distributed matrix A.
*
*  B       (local input) REAL pointer to an
*          array in local memory of dimension (LLD_B, LOCc(JB+N-1)).
*          This array contains the local pieces of the M-by-N
*          distributed test matrix B
*
*  IB      (global input) INTEGER
*          B's global row index, which points to the beginning of the
*          submatrix which is to be operated on.
*
*  JB      (global input) INTEGER
*          B's global column index, which points to the beginning of
*          the submatrix which is to be operated on.
*
*  DESCB   (global and local input) INTEGER array of dimension 8
*          The array descriptor for the distributed matrix B.
*
*  THRESH  (input) REAL
*          A test will count as "failed" if the "error", computed as
*          described below, exceeds THRESH.  Note that the error
*          is scaled to be O(1), so THRESH should be a reasonably
*          small multiple of 1, e.g., 10 or 100.  In particular,
*          it should not depend on the precision (single vs. double)
*          or the size of the matrix.  It must be at least zero.
*
*  Q       (local input) REAL array
*          global dimension (MS, NV),
*          local dimension (DESCA( DLEN_ ), NQ)
*
*          Contains the eigenvectors as computed by PSSYEVX
*
*  IQ      (global input) INTEGER
*          Q's global row index, which points to the beginning of the
*          submatrix which is to be operated on.
*
*  JQ      (global input) INTEGER
*          Q's global column index, which points to the beginning of
*          the submatrix which is to be operated on.
*
*  DESCQ   (global and local input) INTEGER array of dimension 8
*          The array descriptor for the distributed matrix Q.
*
*  C       (local workspace) REAL array,
*          global dimension (MS, NV),
*          local dimension (DESCA( DLEN_ ), MQ)
*
*          Accumulator for computing AQ -QL
*
*  IC      (global input) INTEGER
*          C's global row index, which points to the beginning of the
*          submatrix which is to be operated on.
*
*  JC      (global input) INTEGER
*          C's global column index, which points to the beginning of
*          the submatrix which is to be operated on.
*
*  DESCC   (global and local input) INTEGER array of dimension 8
*          The array descriptor for the distributed matrix C.
*
*  W       (global input) REAL array, dimension (NV)
*
*          Contains the computed eigenvalues
*
*  WORK    (local workspace) REAL array,
*                            dimension (LWORK)
*
*  LWORK   (local input) INTEGER
*          The length of the array WORK.
*          LWORK >= NUMROC( NV, DESCA( NB_ ), MYCOL, 0, NPCOL )
*
*  TSTNRM  (global output) REAL
*
*  RESULT  (global output) INTEGER
*          0 if the test passes
*          1 if the test fails
*
*     .. Local Scalars ..
*
      INTEGER            I, INFO, MYCOL, MYROW, NPCOL, NPROW, NQ
      DOUBLE PRECISION   ANORM, ULP
*     ..
*     .. Parameters ..
      INTEGER            BLOCK_CYCLIC_2D, DLEN_, DTYPE_, CTXT_, M_, N_,
     $                   MB_, NB_, RSRC_, CSRC_, LLD_
      PARAMETER          ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
     $                   CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
     $                   RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
      DOUBLE PRECISION   CONE, CNEGONE, CZERO
      PARAMETER          ( CONE = 1.0D+0, CNEGONE = -1.0D+0,
     $                   CZERO = 0.0D+0 )
*     ..
*     .. External Functions ..
      INTEGER            NUMROC
      DOUBLE PRECISION   DLAMCH, PDLANGE
      EXTERNAL           NUMROC, DLAMCH, PDLANGE
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_GRIDINFO, CHK1MAT, PDGEMM, PDSCAL,
     $                   PXERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*       This is just to keep ftnchek happy
      IF( BLOCK_CYCLIC_2D*CSRC_*CTXT_*DLEN_*DTYPE_*LLD_*MB_*M_*NB_*N_*
     $    RSRC_.LT.0 )RETURN
*
      RESULT = 0
*
      CALL BLACS_GRIDINFO( DESCA( CTXT_ ), NPROW, NPCOL, MYROW, MYCOL )
*
      INFO = 0
      CALL CHK1MAT( MS, 1, MS, 2, IA, JA, DESCA, 7, INFO )
      CALL CHK1MAT( MS, 1, MS, 2, IB, JB, DESCB, 11, INFO )
      CALL CHK1MAT( MS, 1, NV, 2, IQ, JQ, DESCQ, 16, INFO )
      CALL CHK1MAT( MS, 1, NV, 2, IB, JB, DESCB, 20, INFO )
*
      IF( INFO.EQ.0 ) THEN
*
         NQ = NUMROC( NV, DESCA( NB_ ), MYCOL, 0, NPCOL )
*
         IF( IQ.NE.1 ) THEN
            INFO = -14
         ELSE IF( JQ.NE.1 ) THEN
            INFO = -15
         ELSE IF( IA.NE.1 ) THEN
            INFO = -5
         ELSE IF( JA.NE.1 ) THEN
            INFO = -6
         ELSE IF( IB.NE.1 ) THEN
            INFO = -9
         ELSE IF( JB.NE.1 ) THEN
            INFO = -10
         ELSE IF( LWORK.LT.NQ ) THEN
            INFO = -23
         END IF
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL PXERBLA( DESCA( CTXT_ ), 'PDGSEPCHK', -INFO )
         RETURN
      END IF
*
      RESULT = 0
      ULP = DLAMCH( 'Epsilon' )
*
*     Compute product of Max-norms of A and Q.
*
      ANORM = PDLANGE( 'M', MS, MS, A, IA, JA, DESCA, WORK )*
     $        PDLANGE( 'M', MS, NV, Q, IQ, JQ, DESCQ, WORK )
      IF( ANORM.EQ.ZERO )
     $   ANORM = ONE
*
      IF( IBTYPE.EQ.1 ) THEN
*
*        Norm of AQ - BQD
*
*        C = AQ
*
         CALL PDGEMM( 'N', 'N', MS, NV, MS, CONE, A, IA, JA, DESCA, Q,
     $                IQ, JQ, DESCQ, CZERO, C, IC, JC, DESCC )
*
*        Q = QD
*
         DO 10 I = 1, NV
            CALL PDSCAL( MS, W( I ), Q, IQ, JQ+I-1, DESCQ, 1 )
   10    CONTINUE
*
*        C = C - BQ  (i.e. AQ-BQD)
*
         CALL PDGEMM( 'N', 'N', MS, NV, MS, CONE, B, IB, JB, DESCB, Q,
     $                IQ, JQ, DESCQ, CNEGONE, C, IC, JC, DESCC )
*
         TSTNRM = ( PDLANGE( 'M', MS, NV, C, IC, JC, DESCC, WORK ) /
     $            ANORM ) / ( MAX( MS, 1 )*ULP )
*
*
      ELSE IF( IBTYPE.EQ.2 ) THEN
*
*        Norm of ABQ - QD
*
*
*        C = BQ
*
         CALL PDGEMM( 'N', 'N', MS, NV, MS, CONE, B, IB, JB, DESCB, Q,
     $                IQ, JQ, DESCQ, CZERO, C, IC, JC, DESCC )
*
*        Q = QD
*
         DO 20 I = 1, NV
            CALL PDSCAL( MS, W( I ), Q, IQ, JQ+I-1, DESCQ, 1 )
   20    CONTINUE
*
*        Q = AC - Q
*
         CALL PDGEMM( 'N', 'N', MS, NV, MS, CONE, A, IA, JA, DESCA, C,
     $                IC, JC, DESCC, CNEGONE, Q, IQ, JQ, DESCQ )
*
         TSTNRM = ( PDLANGE( 'M', MS, NV, Q, IQ, JQ, DESCQ, WORK ) /
     $            ANORM ) / ( MAX( MS, 1 )*ULP )
*
      ELSE IF( IBTYPE.EQ.3 ) THEN
*
*        Norm of BAQ - QD
*
*
*        C = AQ
*
         CALL PDGEMM( 'N', 'N', MS, NV, MS, CONE, A, IA, JA, DESCA, Q,
     $                IQ, JQ, DESCQ, CZERO, C, IC, JC, DESCC )
*
*        Q = QD
*
         DO 30 I = 1, NV
            CALL PDSCAL( MS, W( I ), Q, IQ, JQ+I-1, DESCQ, 1 )
   30    CONTINUE
*
*        Q = BC - Q
*
         CALL PDGEMM( 'N', 'N', MS, NV, MS, CONE, B, IB, JB, DESCB, C,
     $                IC, JC, DESCC, CNEGONE, Q, IQ, JQ, DESCQ )
*
         TSTNRM = ( PDLANGE( 'M', MS, NV, Q, IQ, JQ, DESCQ, WORK ) /
     $            ANORM ) / ( MAX( MS, 1 )*ULP )
*
      END IF
*
      IF( TSTNRM.GT.THRESH .OR. ( TSTNRM-TSTNRM.NE.0.0D0 ) ) THEN
         RESULT = 1
      END IF
      RETURN
*
*     End of PDGSEPCHK
*
      END


MODULE KindModule

  IMPLICIT NONE
  PRIVATE

  INTEGER, PUBLIC, PARAMETER :: &
    DP = KIND( 1.d0 )
  REAL(DP), PUBLIC, PARAMETER :: &
    Zero  = 0.0_DP, &
    One   = 1.0_DP, &
    Two   = 2.0_DP, &
    Three = 3.0_DP, &
    Four  = 4.0_DP, &
    Five  = 5.0_DP
  REAL(DP), PUBLIC, PARAMETER :: &
    Fifth  = 1.0_DP / 5.0_DP, &
    Fourth = 0.25_DP, &
    Third  = 1.0_DP / 3.0_DP, &
    Half   = 0.5_DP
  REAL(DP), PUBLIC, PARAMETER :: &
    Pi     = ACOS( - 1.0_DP ), &
    TwoPi  = 2.0_DP * Pi, &
    FourPi = 4.0_DP * Pi
  REAL(DP), PUBLIC, PARAMETER :: &
    SqrtTiny = SQRT( TINY( 1.0_DP ) )

END MODULE KindModule


!> sorting and reordering
module modSort
  private

  !> generic sort
  interface sort
    module procedure::qsortI
  end interface

  public::sort

contains

  !> quicksort integer array (driver)
  subroutine qsortI(a,perm)
    integer,intent(inout)::a(:) !< the array
    integer,intent(inout),optional::perm(*) !< the permutation array

    if(present(perm))then
      forall(i=1:size(a))
        perm(i)=i
      end forall
      call qsortI_actual(a,perm=perm,first=1,last=size(a))
    else
      call qsortI_actual(a,first=1,last=size(a))
    end if
  end subroutine

  !> quicksort integer array (actual)
  recursive subroutine qsortI_actual(a,perm,first,last)
    integer,intent(inout)::a(*) !< the array
    integer,intent(inout),optional::perm(*) !< the permutation array
    integer,intent(in)::first,last !< sort section from first to last
    integer::tmp,pivot

    pivot=a((first+last)/2)
    i=first
    j=last
    do while(.true.)
      do while(a(i)<pivot)
        i=i+1
      end do
      do while(pivot<a(j))
        j=j-1
      end do
      if(i>=j) exit
      tmp=a(i)
      a(i)=a(j)
      a(j)=tmp
      if(present(perm))then
        tmp=perm(i)
        perm(i)=perm(j)
        perm(j)=tmp
      end if
      i=i+1
      j=j-1
    end do
    if(present(perm))then
      if(first<i-1) call qsortI_actual(a,perm=perm,first=first,last=i-1)
      if(j+1<last) call qsortI_actual(a,perm=perm,first=j+1,last=last)
    else
      if(first<i-1) call qsortI_actual(a,first=first,last=i-1)
      if(j+1<last) call qsortI_actual(a,first=j+1,last=last)
    end if
  end subroutine

end module


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! This program computes multiple distributed 3D FFTs using the
! non-blocking communication API provided by 2DECOMP&FFT to demonstrate
! the overlap of computation and communication
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

program non_blocking

  use decomp_2d
  use MPI

  implicit none

  include "fftw3.f"

  integer, parameter :: nx=16, ny=16, nz=16
  integer, parameter :: p_row=2, p_col=2
  integer, parameter :: NFFT=20   ! number of independent FFTs
  integer, parameter :: NTEST=5   ! number of MPI_TEST per 1D FFT

  integer :: i,j,k, m,n, nmax, ierror
  real(mytype) :: tmp1, tmp2

  double precision :: t1, t2

  integer, dimension(NFFT) :: handles

  ! FFTW plans for the 1D forward/backward transforms
  integer*8, save :: x_plan_f, x_plan_b
  integer*8, save :: y_plan_f, y_plan_b
  integer*8, save :: z_plan_f, z_plan_b

  ! dummy array used for planning
  complex(mytype), allocatable, dimension(:) :: buf1, buf2

  ! input/output of the FFT
  complex(mytype), allocatable, dimension(:,:,:,:) :: in, out
  ! intermediate Y-pencil storage
  complex(mytype), allocatable, dimension(:,:,:,:) :: wk2
  ! send/recv buffers for non-blocking ALLTOALLV
  complex(mytype), allocatable, dimension(:,:,:,:) :: sbuf, rbuf

  call MPI_INIT(ierror)
  call decomp_2d_init(nx,ny,nz,p_row,p_col)

  ! ===== planning 1D FFT in x =====
  allocate(buf1(xsize(1)), buf2(xsize(1)))

#ifdef DOUBLE_PREC
  call dfftw_plan_dft_1d(x_plan_f, xsize(1), buf1, buf2,  &
       FFTW_FORWARD,  FFTW_MEASURE)
  call dfftw_plan_dft_1d(x_plan_b, xsize(1), buf1, buf2,  &
       FFTW_BACKWARD, FFTW_MEASURE)
#else
  call sfftw_plan_dft_1d(x_plan_f, xsize(1), buf1, buf2,  &
       FFTW_FORWARD,  FFTW_MEASURE)
  call sfftw_plan_dft_1d(x_plan_b, xsize(1), buf1, buf2,  &
       FFTW_BACKWARD, FFTW_MEASURE)
#endif

  deallocate(buf1,buf2)

  ! ===== planning 1D FFT in Y =====
  allocate(buf1(ysize(2)), buf2(ysize(2)))

#ifdef DOUBLE_PREC
  call dfftw_plan_dft_1d(y_plan_f, ysize(2), buf1, buf2,  &
       FFTW_FORWARD,  FFTW_MEASURE)
  call dfftw_plan_dft_1d(y_plan_b, ysize(2), buf1, buf2,  &
       FFTW_BACKWARD, FFTW_MEASURE)
#else
  call sfftw_plan_dft_1d(y_plan_f, ysize(2), buf1, buf2,  &
       FFTW_FORWARD,  FFTW_MEASURE)
  call sfftw_plan_dft_1d(y_plan_b, ysize(2), buf1, buf2,  &
       FFTW_BACKWARD, FFTW_MEASURE)
#endif

  deallocate(buf1,buf2)

  ! ===== planning 1D FFT in Z =====
  allocate(buf1(zsize(3)), buf2(zsize(3)))

#ifdef DOUBLE_PREC
  call dfftw_plan_dft_1d(z_plan_f, zsize(3), buf1, buf2,  &
       FFTW_FORWARD,  FFTW_MEASURE)
  call dfftw_plan_dft_1d(z_plan_b, zsize(3), buf1, buf2,  &
       FFTW_BACKWARD, FFTW_MEASURE)
#else
  call sfftw_plan_dft_1d(z_plan_f, zsize(3), buf1, buf2,  &
       FFTW_FORWARD,  FFTW_MEASURE)
  call sfftw_plan_dft_1d(z_plan_b, zsize(3), buf1, buf2,  &
       FFTW_BACKWARD, FFTW_MEASURE)
#endif

  deallocate(buf1,buf2)

  allocate( in(xsize(1),xsize(2),xsize(3),NFFT))   ! x-pencil input
  allocate(out(zsize(1),zsize(2),zsize(3),NFFT))   ! z-pencil output
  allocate(wk2(ysize(1),ysize(2),ysize(3),NFFT))   ! y-pencil intermediate

  ! send/recv buffers
  allocate(sbuf(ysize(1),ysize(2),ysize(3),0:1))   ! y-pencil
  allocate(rbuf(zsize(1),zsize(2),zsize(3),0:1))   ! z-pencil

  ! 1D temp buffer
  nmax = max(xsize(1),max(ysize(2),zsize(3)))
  allocate (buf1(nmax))
  allocate (buf2(nmax))

  t1 = MPI_WTIME()

  ! first data set: V_1
  do k=1,xsize(3)
     do j=1,xsize(2)
        do i=1,xsize(1)
           tmp1 = real(xstart(1)+i-1, mytype) / real(nx, mytype) &
                * real(xstart(2)+j-1, mytype) / real(ny, mytype) &
                * real(xstart(3)+k-1, mytype) / real(nz, mytype) &
                * 1._mytype / real(NFFT, mytype)
           in(i,j,k,1) = cmplx(tmp1, 0._mytype, mytype)
        end do
     end do
  end do

  ! 1D FFT in X for V_1
  do k=1,xsize(3)
     do j=1,xsize(2)
        do i=1,xsize(1)
           buf1(i) = in(i,j,k,1)
        end do
#ifdef DOUBLE_PREC
        call dfftw_execute_dft(x_plan_f, buf1, buf2)
#else
        call sfftw_execute_dft(x_plan_f, buf1, buf2)
#endif
        do i=1,xsize(1)
           in(i,j,k,1) = buf2(i)
        end do
     end do
  end do

  ! transpose X->Y for V_1 (blocking)
  call transpose_x_to_y(in(:,:,:,1),wk2(:,:,:,1))

  ! 1D FFT in Y for V_1
  do k=1,ysize(3)
     do i=1,ysize(1)
        do j=1,ysize(2)
           buf1(j) = wk2(i,j,k,1)
        end do
#ifdef DOUBLE_PREC
        call dfftw_execute_dft(y_plan_f, buf1, buf2)
#else
        call sfftw_execute_dft(y_plan_f, buf1, buf2)
#endif
        do j=1,ysize(2)
           wk2(i,j,k,1) = buf2(j)
        end do
     end do
  end do

  ! initiate transpose Y->Z for V_1
  call transpose_y_to_z_start(handles(1),wk2(:,:,:,1),out(:,:,:,1), &
       sbuf(:,:,:,1),rbuf(:,:,:,1))

  ! Loop through remaining data sets
  do m=2,NFFT

     ! new data set: V_m
     do k=1,xsize(3)
        do j=1,xsize(2)
           do i=1,xsize(1)
              tmp1 = real(xstart(1)+i-1, mytype) / real(nx, mytype) &
                   * real(xstart(2)+j-1, mytype) / real(ny, mytype) &
                   * real(xstart(3)+k-1, mytype) / real(nz, mytype) &
                   * real(m, mytype) / real(NFFT, mytype)
              in(i,j,k,m) = cmplx(tmp1, 0._mytype, mytype)
           end do
        end do
     end do

     ! 1D FFT in X for V_m
     do k=1,xsize(3)
        do j=1,xsize(2)
           do i=1,xsize(1)
              buf1(i) = in(i,j,k,m)
           end do
#ifdef DOUBLE_PREC
           call dfftw_execute_dft(x_plan_f, buf1, buf2)
#else
           call sfftw_execute_dft(x_plan_f, buf1, buf2)
#endif
           do n=1,NTEST
              call transpose_test(handles(m-1))
           end do
           do i=1,xsize(1)
              in(i,j,k,m) = buf2(i)
           end do
        end do
     end do

     ! transpose X->Y for V_m (blocking)
     call transpose_x_to_y(in(:,:,:,m),wk2(:,:,:,m))

     ! 1D FFT in Y for V_m
     do k=1,ysize(3)
        do i=1,ysize(1)
           do j=1,ysize(2)
              buf1(j) = wk2(i,j,k,m)
           end do
#ifdef DOUBLE_PREC
           call dfftw_execute_dft(y_plan_f, buf1, buf2)
#else
           call sfftw_execute_dft(y_plan_f, buf1, buf2)
#endif
           do n=1,NTEST
              call transpose_test(handles(m-1))
           end do
           do j=1,ysize(2)
              wk2(i,j,k,m) = buf2(j)
           end do
        end do
     end do

     ! NOTE: there are two transposes ongoing at any time
     ! The mod operation is to use different sets of send/recv buffers

     ! initiate transpose Y->Z for V_m
     call transpose_y_to_z_start(handles(m),wk2(:,:,:,m),out(:,:,:,m), &
          sbuf(:,:,:,mod(m,2)),rbuf(:,:,:,mod(m,2)))

     ! wait for transpose complete for V_m-1
     call transpose_y_to_z_wait(handles(m-1),wk2(:,:,:,m-1),out(:,:,:,m-1), &
          sbuf(:,:,:,mod(m-1,2)),rbuf(:,:,:,mod(m-1,2)))

     ! 1D FFT in Z for V_m-1
     do j=1,zsize(2)
        do i=1,zsize(1)
           do k=1,zsize(3)
              buf1(k) = out(i,j,k,m-1)
           end do
#ifdef DOUBLE_PREC
           call dfftw_execute_dft(z_plan_f, buf1, buf2)
#else
           call sfftw_execute_dft(z_plan_f, buf1, buf2)
#endif
           do k=1,zsize(3)
              out(i,j,k,m-1) = buf2(k)
           end do
        end do
     end do

     if (nrank==0) write(*,*) 'TEST ', m-1, out(1:2,1:2,1:2,m-1)

  end do ! NTEST Loop

  ! wait for transpose complete for V_NFFT
  call transpose_y_to_z_wait(handles(NFFT),wk2(:,:,:,NFFT),out(:,:,:,NFFT), &
       sbuf(:,:,:,mod(NFFT,2)),rbuf(:,:,:,mod(NFFT,2)))

  ! 1D FFT in Z for V_NFFT
  do j=1,zsize(2)
     do i=1,zsize(1)
        do k=1,zsize(3)
           buf1(k) = out(i,j,k,NFFT)
        end do
#ifdef DOUBLE_PREC
        call dfftw_execute_dft(z_plan_f, buf1, buf2)
#else
        call sfftw_execute_dft(z_plan_f, buf1, buf2)
#endif
        do k=1,zsize(3)
           out(i,j,k,NFFT) = buf2(k)
        end do
     end do
  end do

  if (nrank==0) write(*,*) 'TEST ', NFFT, out(1:2,1:2,1:2,NFFT)

  t2 = MPI_WTIME() - t1
  call MPI_ALLREDUCE(t2,t1,1,MPI_DOUBLE_PRECISION,MPI_SUM, &
       MPI_COMM_WORLD,ierror)
  t1 = t1 / real(nproc, mytype)

  if (nrank==0) then
     write(*,*) 'Average Forward FFT Time(sec): ', t1
  end if

  ! clean up
#ifdef DOUBLE_PREC
  call dfftw_destroy_plan(x_plan_f)
  call dfftw_destroy_plan(x_plan_b)
  call dfftw_destroy_plan(y_plan_f)
  call dfftw_destroy_plan(y_plan_b)
  call dfftw_destroy_plan(z_plan_f)
  call dfftw_destroy_plan(z_plan_b)
#else
  call sfftw_destroy_plan(x_plan_f)
  call sfftw_destroy_plan(x_plan_b)
  call sfftw_destroy_plan(y_plan_f)
  call sfftw_destroy_plan(y_plan_b)
  call sfftw_destroy_plan(z_plan_f)
  call sfftw_destroy_plan(z_plan_b)
#endif

  call decomp_2d_finalize
  call MPI_FINALIZE(ierror)
  deallocate(in,out,wk2,buf1,buf2,sbuf,rbuf)

end program non_blocking


module mc_sample_mod
  implicit none
  save
contains

  subroutine mc_sample(C,L,WL)
    use search_bisec_mod
  !****---------------------------
  ! ****Returns sampled WL in nm
  !***----------------------------
  implicit none

  real*8, intent(in) :: l(:),c(:)
  real*8, intent(out) :: wl
  real*8 :: ran
  integer:: low, up

  call random_number(ran)
  call search_bisec(ran,c,low,up)

  !use interpolation to find corresponding wavelength
  wl = (l(up) - l(low)) * (ran-c(low)) / (c(up)-c(low))
  wl = l(low) + wl

  return
end subroutine mc_sample

end module


! $UWHPSC/codes/fortran/demo1.f90

program demo1

! Fortran 90 program illustrating data types.

implicit none   ! to give error if a variable not declared
real :: x
real (kind=8) :: y, z
integer :: m

m = 3
print *, " "
print *, "M = ",M   ! note that M==m  (case insensitive)

print *, " "
print *, "x is real (kind=4)"
x = 1.e0 + 1.23456789e-6
print *, "x = ", x

print *, " "
print *, "y is real (kind=8)"
print *, "  but 1.e0 is real (kind=4):"
y = 1.e0 + 1.23456789e-6
print *, "y = ", y

print *, " "
print *, "z is real (kind=8)"
z = 1. + 1.23456789d-6
print *, "z = ", z

end program demo1


!!!!!!!!!!!!!/
! dgeqrf example
! see: http:!www.netlib.org/lapack/explore-html/df/dc5/group__variants_g_ecomputational_ga3766ea903391b5cf9008132f7440ec7b.html
!!!!!!!!!!!!!!/
!
program dgeqrf
  use iso_c_binding
  use hipfort
  use hipfort_check
  use hipfort_rocblas
  use hipfort_rocsolver

  implicit none
  integer :: i, j ! indices for iterating over results

  ! Define our input data
  real(c_double), target :: hA(3,3) = reshape((/12, 6, -4, -51, 167, 24, 4, -68, -41/), (/3, 3/))
  real(c_double), target :: hResult(3,3) = reshape((/&
  -14.000000000000000,       -21.000000000000000,        14.000000000000002,&
  0.23076923076923078,       -175.00000000000000,        70.000000000000000,&
 -0.15384615384615385,        5.5555555555555559E-002,  -35.000000000000000/), shape(hResult), order=(/2,1/))
  integer(c_int), parameter :: M = 3
  integer(c_int), parameter :: N = 3
  integer(c_int), parameter :: lda = 3

  real(c_double), target :: hIpiv(3) ! CPU buffer for Householder scalars
  integer(c_size_t) :: size_A = size(hA)
  integer(c_size_t) :: size_Ipiv = size(hIpiv)

  type(c_ptr) :: dA     ! GPU buffer for A
  type(c_ptr) :: dIpiv  ! GPU buffer for Householder scalars

  type(c_ptr) :: handle ! rocblas_handle

  real :: error
  real, parameter :: error_max = 10 * epsilon(error_max)
  !
  write(*,"(a)",advance="no") "-- Running test 'rocsolver_dgeqrf' (Fortran 2003 interfaces) - "

  ! Allocate device-side memory
  call hipCheck(hipMalloc(dA, size_A * 8))
  call hipCheck(hipMalloc(dIpiv, size_Ipiv * 8))

  ! Create rocBLAS handle
  call hipCheck(rocblas_create_handle(handle))

  ! Copy memory from host to device
  call hipCheck(hipMemcpy(dA, c_loc(hA), size_A * 8, hipMemcpyHostToDevice))

  ! Compute the QR factorization on the devi ce
  call hipCheck(rocsolver_dgeqrf(handle, M, N, dA, lda, dIpiv))

  ! Copy result from device to host
  call hipCheck(hipMemcpy(c_loc(hA), dA, size_A * 8, hipMemcpyDeviceToHost))
  call hipCheck(hipMemcpy(c_loc(hIpiv), dIpiv, size_Ipiv * 8, hipMemcpyDeviceToHost))

  ! Output results
  do j = 1,size(hA,2)
    do i = 1,size(hA,1)
        error = abs(hA(i,j) - hResult(i,j))
        if(error .gt. error_max) then
            write(*,*) "FAILED! Error bigger than max! Error = ", error, " hA(", i, ",", j, ") = ", hA(i,j)
            call exit
        end if
      ! print *, (hA(i,j), j=1,size(hA,2))
      ! print *, (hResult(i,j), j=1,size(hA,2))
    end do
  end do

  ! Clean up
  call hipCheck(hipFree(dA))
  call hipCheck(hipFree(dIpiv))
  call hipCheck(rocblas_destroy_handle(handle))
  call hipCheck(hipDeviceReset())

  write(*,*) "PASSED!"

end program dgeqrf