module util

implicit none

real(kind=8),parameter  :: pi=3.141592653589793238d0
complex(kind=8),parameter :: i_imag=cmplx(0,1,kind=8)
real(kind=8),parameter :: eleVolt = 1.609d-19
real(kind=8),parameter :: mass_proton = 1.6726219d-27
real(kind=8),parameter :: kb = 1.380649d-23
real(kind=8),parameter :: hbar = 1.0545718d-34

contains
! Returns the inverse of a matrix calculated by finding the LU
! decomposition.  Depends on LAPACK.
function inv(A) result(Ainv)
  complex(kind=8), dimension(:,:), intent(in) :: A
  complex(kind=8), dimension(size(A,1),size(A,2)) :: Ainv

  complex(kind=8), dimension(size(A,1)) :: work  ! work array for LAPACK
  integer, dimension(size(A,1)) :: ipiv   ! pivot indices
  integer :: i, n, info, tag

  ! External procedures defined in LAPACK
  external ZGETRF
  external ZGETRI

  ! Store A in Ainv to prevent it from being overwritten by LAPACK
  tag = ifnan(A)
  if (tag .eq. 1) then
      stop
  end if

  Ainv(:,:) = A(:,:)
  n = size(A,1)
  !do i = 1,n
  !   Ainv(i,i) = Ainv(i,i) + 1.0d-16
  !end do

  ! ZGETRF computes an LU factorization of a general M-by-N matrix A
  ! using partial pivoting with row interchanges.
  call ZGETRF(n, n, Ainv, n, ipiv, info)

  if (info /= 0) then
     ! = 0:  successful exit
     !     < 0:  if INFO = -i, the i-th argument had an illegal value
     !     > 0:  if INFO = i, U(i,i) is exactly zero. The factorization
     !           has been completed, but the factor U is exactly
     !           singular, and division by zero will occur if it is used
     !           to solve a system of equations.
      write(*,*) 'info'
      write(*,*) info
      write(*,*) Ainv(info,info)
      write(*,*) 'A'
      write(*,*) A(1,:)
     write(*,*) 'Dimension of matrix:', size(A,1)
     stop 'Matrix is numerically singular!'
  end if

  ! ZGETRI computes the inverse of a matrix using the LU factorization
  ! computed by ZGETRF.
  call ZGETRI(n, Ainv, n, ipiv, work, n, info)

  if (info /= 0) then
     stop 'Matrix inversion failed!'
  end if
  end function inv

  function psinv(A) result(Ainv)

  complex(kind=8), dimension(:,:), intent(in) :: A
  complex(kind=8), dimension(size(A,1),size(A,2)) :: Ainv
  integer(kind=4) :: LDA, LDU, LDVT
  integer(kind=4) :: LWMAX
  integer(kind=4) :: INFO,LWORK
  complex(kind=8) :: S(size(A,1)), Rwork(5*size(A,1))
  complex(kind=8) ::U(size(A,1),size(A,1)), VT(size(A,2),size(A,2)),&
                    WORK(1000)
  complex(kind=8) :: SS(size(A,1))
  integer(kind=4) :: m,n,i,incx
  complex(kind=8) :: alpha=1.0d0
  complex(kind=8) :: beta=0.0d0

  external ZGESVD
  external zgemm
  external zscal

  incx = 1 ! INCX is INTEGER storage spacing between elements of ZX
  lwmax = 1000

  m = size(A,1)
  n = size(A,2)
  LDA = m
  LDU = m
  LDVT = n

  LWORK = -1
  CALL ZGESVD( 'All', 'All', M, N, A, LDA, S, U, LDU, VT, LDVT,&
             WORK, LWORK, RWORK, INFO )
  LWORK = MIN( LWMAX, INT( WORK( 1 ) ) )

!     Compute SVD.
  CALL ZGESVD( 'A', 'A', M, N, A, LDA, S, U, LDU, VT, LDVT,&
             WORK, LWORK, RWORK, INFO )

  SS = 0.0d0
  do i = 1,m
      if (abs(s(i)) > 1.0d-17) then
          SS(i) = 1.0d0/s(i)
          call zscal(m,ss(i),u(i,:),incx)
      end if
  end do

  call zgemm('T','T',n,m,m,alpha,vt,ldvt,&
        u,ldu,beta,Ainv,n)

!     Check for convergence.

  IF( INFO.GT.0 ) THEN
     WRITE(*,*)'The algorithm computing SVD failed to converge.'
!     STOP
  END IF
  end function psinv

  ! matrix inversion for real matrix
  function inv_real(A) result(Ainv)
  real(kind=8), dimension(:,:), intent(in) :: A
  real(kind=8), dimension(size(A,1),size(A,2)) :: Ainv

  real(kind=8), dimension(size(A,1)) :: work  ! work array for LAPACK
  integer, dimension(size(A,1)) :: ipiv   ! pivot indices
  integer :: n, info

  ! External procedures defined in LAPACK
  external DGETRF
  external DGETRI

  ! Store A in Ainv to prevent it from being overwritten by LAPACK
  Ainv = A
  n = size(A,1)

  ! DGETRF computes an LU factorization of a general M-by-N matrix A
  ! using partial pivoting with row interchanges.
  call DGETRF(n, n, Ainv, n, ipiv, info)

  if (info /= 0) then
     stop 'Matrix is numerically singular!'
  end if

  ! DGETRI computes the inverse of a matrix using the LU factorization
  ! computed by DGETRF.
  call DGETRI(n, Ainv, n, ipiv, work, n, info)

  if (info /= 0) then
     stop 'Matrix inversion failed!'
  end if
  end function inv_real

  function diagmat(eigs) result(mat)
  complex(kind=8),intent(in) :: eigs(:)
  complex(kind=8) :: mat(size(eigs,1),size(eigs,1))
  integer(kind=4) :: i

  mat = 0.0d0
  do i = 1,size(eigs,1)
      mat(i,i) = eigs(i)
  end do

  end function diagmat

  function eyemat(n) result(mat)
  integer(kind=4),intent(in) :: n
  real(kind=8) :: mat(n,n)
  integer(kind=4) :: i
  mat = 0.0d0
  do i = 1, n
    mat(i,i) = 1.0d0
  end do
  end function eyemat

  function eyemat_cmplx(n) result(mat)
  integer(kind=4),intent(in) :: n
  complex(kind=8) :: mat(n,n)
  integer(kind=4) :: i
  mat = 0.0d0
  do i = 1, n
    mat(i,i) = 1.0d0
  end do
  end function eyemat_cmplx

  subroutine eigenH(A,w,vecr)

  integer(kind=4) :: nwork=1
  integer(kind=4) :: info
  real(kind=8),allocatable :: rwork(:)
  complex(kind=8),allocatable :: work(:)
  complex(kind=8),intent(in) :: A(:,:)
  complex(kind=8),dimension(size(A,1),size(A,2)) :: At
  real(kind=8),dimension(size(A,1)),intent(out) :: w
  complex(kind=8),dimension(size(A,1),size(A,2)),&
               intent(out) :: vecr
  integer(kind=4) :: n

  n = size(A,1)
  At = A
  allocate(work(nwork))
  allocate(rwork(3*n))

  ! compute the eigenvalue and eigenvector
  ! of Hermitian matrix
  ! info = 0, the eigenvalues in ascending order
  call zheev("V","U",n,At(:,:),n,w,work,-1,rwork,info)

  if(real(work(1)).gt.nwork) then
        nwork=idnint(2*real(work(1)))
        deallocate(work)
        allocate(work(nwork))
  end if

  call zheev("V","U",n,At(:,:),n,w,work,nwork,rwork,info)
  vecr = At
  end subroutine

  subroutine eigen(A,w,vecr)
  ! compute the eigenvalue and eigenvectors for a
  ! n by n nonsymmetric complex matrix
  complex(kind=8), dimension(:,:), intent(in) :: A
  complex(kind=8), dimension(size(A,1),size(A,2)) :: Atemp
  complex(kind=8), dimension(size(A,1),size(A,2)) :: Asq
  complex(kind=8), intent(out) :: w(size(A,1))
  complex(kind=8), allocatable :: work(:)
  real(kind=8), allocatable :: rwork(:)
  complex(kind=8), dimension(size(A,1),size(A,2)) :: vecl
  complex(kind=8),dimension(size(A,1),size(A,2)),intent(out) :: vecr
  integer(kind=4) :: lda,  info, nwork = 1

  Atemp = A

  if (size(A,1) /= size(A,2)) then
    stop 'Not a square matrix!'
  end if
  lda = max(size(A,1),1)
  allocate(rwork(max(1,2*lda)))
  allocate(work(nwork))

  call ZGEEV("N", "V", lda, Atemp, lda, w,&
   vecl, lda, vecr, lda,work,-1,&
   rwork, info)

  if(real(work(1)).gt.nwork) then
        nwork=idnint(2*real(work(1)))
        deallocate(work)
        allocate(work(nwork))
  end if

  call ZGEEV("N", "V", lda, Atemp, lda, w,&
   vecl, lda, vecr, lda,work,nwork,&
   rwork, info)

  end subroutine eigen

  subroutine eigen_sorting(A,w,vecr)
  ! compute the eigenvalue and eigenvectors for a
  ! n by n nonsymmetric complex matrix
  complex(kind=8), dimension(:,:), intent(in) :: A
  complex(kind=8), dimension(size(A,1),size(A,2)) :: Atemp
  complex(kind=8), dimension(size(A,1),size(A,2)) :: Asq
  complex(kind=8), intent(out) :: w(size(A,1))
  integer(kind=4) :: sort_idx(size(A,1))
  complex(kind=8), allocatable :: work(:)
  real(kind=8), allocatable :: rwork(:)
  complex(kind=8), dimension(size(A,1),size(A,2)) :: vecl
  complex(kind=8), dimension(size(A,1),size(A,2)) :: vecp
  complex(kind=8),dimension(size(A,1),size(A,2)),intent(out) :: vecr
  integer(kind=4) :: lda,  info, nwork = 1
  integer(kind=4) :: i,nprop

  Atemp = A

  if (size(A,1) /= size(A,2)) then
    stop 'Not a square matrix!'
  end if
  lda = max(size(A,1),1)
  allocate(rwork(max(1,2*lda)))
  allocate(work(nwork))

  call ZGEEV("N", "V", lda, Atemp, lda, w,&
   vecl, lda, vecr, lda,work,-1,&
   rwork, info)

  if(real(work(1)).gt.nwork) then
        nwork=idnint(2*real(work(1)))
        deallocate(work)
        allocate(work(nwork))
  end if

  call ZGEEV("N", "V", lda, Atemp, lda, w,&
   vecl, lda, vecr, lda,work,nwork,&
   rwork, info)

   sort_idx = sorting_index_descent(abs(w))
   w = w(sort_idx)         ! order the eigenvalue
   vecr = vecr(:,sort_idx) ! according to their amplitude

   nprop = 0
   vecp = 0.0d0

   do i = 1,size(A,1)
        if ((abs(abs(w(i))-1.0d0) .gt. 5.0d-3).and.(i.gt.1)) then
           go to 102
        end if
   end do

   102 nprop = i-1
   if (nprop .gt. 0) then
       vecp(:,1:nprop) = vecr(:,1:nprop)
       vecr(:,1:nprop) = gram_schmidt(vecp(:,1:nprop))
   end if

  end subroutine eigen_sorting

  LOGICAL FUNCTION DUMMY_SELECT(ARG)
  IMPLICIT NONE

  COMPLEX(kind=8),intent(in) :: ARG

  DUMMY_SELECT = (ARG .EQ. ARG)

  end function DUMMY_SELECT

  function ifnan(A) result(idx)

  complex(kind=8),dimension(:,:),intent(in) :: A
  integer(kind=4) :: idx,m,n,i,j
  real(kind=8) :: infinity

  infinity = huge(8)
  m = size(A,1)
  n = size(A,2)
  idx = 0
  do i = 1,m
      do j = 1,n
          if (isnan(abs(A(i,j)))) then
              write(*,*)'nan', i,j
              idx = 1
              go to 3233
          end if
      end do
  end do

  3233 continue

  end function ifnan

  function sqrtm(A) result(QUQH)
  ! Firstly, computes for an N-by-N complex nonsymmetric
  ! matrix A, the eigenvalues, the Schur form T.

  complex(kind=8), dimension(:,:), intent(in) :: A
  complex(kind=8), dimension(size(A,1),size(A,2)) :: S
  complex(kind=8) :: w(size(A,1))
  complex(kind=8), allocatable :: work(:)
  real(kind=8), allocatable :: rwork(:)
  logical,allocatable :: bwork(:)
  complex(kind=8), dimension(size(A,1),size(A,2)) :: q
  complex(kind=8), dimension(size(A,1),size(A,2)) :: U
  complex(kind=8), dimension(size(A,1),size(A,2)) :: QUQH
  complex(kind=8), dimension(size(A,1),size(A,2)) :: QU
  integer(kind=4) :: N,info,nwork = 1
  integer(kind=4) :: i,j,k,sdim, sdiag
  integer(kind=4) :: tag

  sdim = 0
  tag = ifnan(A)
  if (tag .eq. 1) then
      stop
  end if

  S(:,:) = A(:,:)
  q = 0.0d0
  U = 0.0d0
  QUQH = 0.0d0
  QU = 0.0d0

  if (size(A,1) /= size(A,2)) then
    stop 'Not a square matrix!'
  end if
  N = max(size(A,1),1)
  allocate(rwork(max(1,N)))
  allocate(bwork(N))
  allocate(work(nwork))

  call ZGEES('V', 'N',DUMMY_SELECT, N, &
   S, N, sdim, w,&
   q, N,work,-1,&
   rwork, bwork, info)

  if(real(work(1)).gt.nwork) then
        nwork=idnint(2*real(work(1)))
        deallocate(work)
        allocate(work(nwork))
  end if

  call ZGEES('V', 'N',DUMMY_SELECT, N, &
  S, N, sdim, w,&
  q, N,work,nwork,&
  rwork, bwork, info)

  do j = 1,N-1              ! set the lower triangle to zero
        do i = j+1,N
           U(i,j) = 0.0d0
        enddo
  enddo

  do i = 1,N                ! set the diagonal elements
        U(i,i) = sqrt(S(i,i))
  enddo

  do sdiag = 1,N-1          ! loop over the N-1 super-diagonals
     do i = 1,N-sdiag
         j = i+sdiag
         U(i,j) = S(i,j)
         do k = i+1,j-1
             U(i,j) = U(i,j) - U(i,k)*U(k,j)
         enddo
         if ((U(i,i) + U(j,j)) .ne. cmplx(0.0,0.0,kind=8))then
             U(i,j) = U(i,j) / (U(i,i) + U(j,j))
         else
             U(i,j) = 0.0d0
         end if
     enddo
  enddo
  call ZGEMM('N', 'N', N, N, N, cmplx(1.0,0.0,kind=8), Q, N, U, N, cmplx(0.0,0.0,kind=8), QU, N)
  call ZGEMM('N', 'C', N, N, N, cmplx(1.0,0.0,kind=8), QU, N,Q, N, cmplx(0.0,0.0,kind=8), QUQH, N)
  if(info /= 0) then
       write(*,*) 'S'
       write(*,*) S
       stop
       write(*,*) 'U'
       write(*,*) U
       !write(*,*) U
       !write(*,*) QU
       !write(*,*) QUQH
       write(*,*) "zgemm returned info = ", info
       write(*,*) "the ", info, "-th argument had an illegal value"
       stop
  end if

  end function

  function lstsq(A, b) result(x)
  ! compute least square solution to A x = B for cmplx A, b
  complex(kind=8), intent(in) :: A(:,:), B(:,:)
  complex(kind=8), allocatable :: x(:,:)
  ! LAPACK variables:
  integer :: info, lda, ldb, lwork, m, n, nrhs, rank
  real(kind=8) :: rcond
  real(kind=8),allocatable :: rwork(:)
  complex(kind=8), allocatable :: work(:), At(:,:), Bt(:,:)
  integer, allocatable :: jpvt(:)

  m = size(A,1)
  n = size(A,2)
  nrhs = size(B,2)
  lda = max(1,m)
  ldb = max(1,m,n)
  allocate(x(n,nrhs), At(m,n), Bt(m,nrhs), &
            jpvt(n), work(1),rwork(2*n))
  rcond = 0.0
  jpvt(:) = 0
  Bt(:,:) = B(:,:)  ! only one right-hand side
  At(:,:) = A(:,:)
  call zgelsy(m, n, nrhs, At, lda, Bt, ldb,&
        jpvt, rcond, rank, work, &
         -1, rwork, info)  ! query optimal workspace size
  lwork = int(real(work(1)))
  deallocate(work)
  allocate(work(lwork))  ! allocate with ideal size

  call zgelsy(m, n, nrhs, At, lda, Bt, ldb,&
         jpvt, rcond, rank, work, &
         lwork, rwork, info)
  if(info /= 0) then
       write(*,*) "zgelsy returned info = ", info
       write(*,*) "the ", info, "-th argument had an illegal value"
  end if
  x(:,:) = Bt(:,:)
  end function lstsq

  function trace(A) result(X)
  complex(kind=8),intent(in) :: A(:,:)
  complex(kind=8) :: X
  integer(kind=4) :: i, n

  if (size(A,1) /= size(A,2)) then
    stop 'Not a square matrix!'
  end if

  n = size(A,1)

  X = 0.0d0

  do i = 1,n
    X = A(i,i) + X
  end do
  end function trace

  subroutine find_degenerate(eigval,start,idx_list,next_start,case_no,&
             deg_all)

  implicit none

  complex(kind=8),dimension(:),intent(in) :: eigval
  complex(kind=8) :: edeg
  integer(kind=4),intent(in) :: start
  integer(kind=4),dimension(:),intent(in) :: deg_all
  integer(kind=4),intent(out) :: next_start
  integer(kind=4),intent(out) :: case_no
  integer(kind=4),allocatable,intent(out) :: idx_list(:)
  integer(kind=4) :: ne, i, j, edeg_idx,&
                     n, itemp
  complex(kind=8),allocatable :: temp(:)

  itemp = 0
  next_start = 0
  case_no = 0 ! case number is zero meaning there are no degenerate states
  ne = size(eigval,1)
  outer: do i = start, ne-1
      do j = i+1,ne
          if ((abs(eigval(i)-eigval(j)) .lt. 1.0d-4).and.&
           (abs(abs(eigval(j))-1.0d0) .lt. 1.0d-3)) then
              case_no = 1
              edeg_idx = j
              itemp = i
              edeg = eigval(edeg_idx)
          end if
          if( case_no .eq. 1) exit outer
      end do
  end do outer

  next_start = itemp+1

  n = 0
  if (ALLOCATED(idx_list)) then
      deallocate(idx_list)
  end if
  allocate(idx_list(1))
  idx_list = 0

  allocate(temp(1))

  if (case_no .eq. 1) then
     do i = 1, ne
         if (abs(eigval(i)-edeg) .lt. 1.0d-4) then
             n = n + 1
             if (n.eq.1) then
                 idx_list(1) = i
                 temp(1) = i
             else
                 deallocate(idx_list)
                 allocate(idx_list(n))
                 idx_list(1:n-1) = temp(:)
                 idx_list(n) = i ! append new element

                 deallocate(temp)
                 allocate(temp(n))
                 temp = idx_list
             end if
         end if
     end do
     do i =1,size(idx_list,1)
         do j = 1,size(deg_all,1)
             if (idx_list(i).eq.deg_all(j)) then
                 deallocate(idx_list)
                 allocate(idx_list(1))
                 idx_list(1) = 0
             end if
         end do
     end do
  end if

  end subroutine find_degenerate

  function in_ws(a_vectors,k_pos) result(output)

    implicit none

    real(kind=8),intent(in) :: a_vectors(3,3), k_pos(3)
    real(kind=8) :: dist(125),dist_min,dist_min2
    real(kind=8) :: dist_remain(124)
    integer(kind=4) :: min_idx
    integer(kind=4) :: icnt,i1,i2,i3
    real(kind=8) :: ndiff(3)
    integer(kind=4) :: output

    dist = 0
    icnt = 0
    do i1 =-2,2
        do i2 =-2,2
            do i3 =-2,2
                ndiff(1) = dble(i1)
                ndiff(2) = dble(i2)
                ndiff(3) = dble(i3)

                icnt =icnt+ 1

                dist(icnt) = dot_product(k_pos-matmul(ndiff,a_vectors),&
                                         k_pos-matmul(ndiff,a_vectors))
            end do
        end do
    end do
    dist_min = minval(dist)

    ! find the second smallest element
    min_idx = minloc(dist,1)
    if (min_idx .eq. 1) then
        dist_remain = dist(2:125)
    else if (min_idx .eq. 125) then
        dist_remain = dist(1:124)
    else
        dist_remain(1:min_idx-1) = dist(1:min_idx-1)
        dist_remain(min_idx:124) = dist(min_idx+1:125)
    end if
    dist_min2 = minval(dist_remain)

    if (abs(dist_min2-dist_min).lt.1.0d-5) then
        output = 2
    else if (abs(dist(63)-dist_min) .lt. 1d-5) then
        output = 1
    else
        output = 0
    end if
    end function in_ws

    function move_in_ws3(k_pos,a_vectors) result(output)

    implicit none

    real(kind=8),intent(in) :: a_vectors(3,3), k_pos(3)
    real(kind=8) :: dist(125)
    integer(kind=4) :: i_min
    integer(kind=4) :: icnt,i1,i2,i3
    real(kind=8) :: ndiff(3)
    real(kind=8) :: output(3)
    real(kind=8) :: k_all(125,3)

    dist = 0
    icnt = 0
    k_all(:,:) = 0.0d0

    do i1 =-2,2
        do i2 =-2,2
            do i3 =-2,2
                ndiff(1) = dble(i1)
                ndiff(2) = dble(i2)
                ndiff(3) = dble(i3)

                icnt =icnt+ 1
                k_all(icnt,:) = ndiff
                dist(icnt) = dot_product(k_pos-matmul(ndiff,a_vectors),&
                                         k_pos-matmul(ndiff,a_vectors))
            end do
        end do
    end do
    i_min = minloc(dist,1)
    output = k_pos - matmul(k_all(i_min,:),a_vectors)

    end function move_in_ws3

    function move_in_ws2(k_pos,a_vectors) result(output)

    implicit none

    real(kind=8),intent(in) :: a_vectors(3,3), k_pos(3)
    real(kind=8) :: dist(25)
    integer(kind=4) :: i_min
    integer(kind=4) :: icnt,i1,i2,i3
    real(kind=8) :: ndiff(3)
    real(kind=8) :: output(3)
    real(kind=8) :: k_all(25,3)

    dist = 0
    icnt = 0
    k_all(:,:) = 0.0d0

    do i1 =-2,2
        do i2 =-2,2
                ndiff(1) = dble(i1)
                ndiff(2) = dble(i2)
                ndiff(3) = 0.0d0

                icnt =icnt+ 1
                k_all(icnt,:) = ndiff
                dist(icnt) = dot_product(k_pos-matmul(ndiff,a_vectors),&
                                         k_pos-matmul(ndiff,a_vectors))
        end do
    end do
    i_min = minloc(dist,1)
    output = k_pos - matmul(k_all(i_min,:),a_vectors)

    end function move_in_ws2

    function get_pos_index_in_pc(pos_sc,pos_pc,recivec) result(idx)

    implicit none

    real(kind=8),intent(in) :: pos_sc(3)
    real(kind=8),intent(in) :: pos_pc(:,:)
    real(kind=8),intent(in) :: recivec(3,3)
    integer(kind=4) :: natm_pc, i, idx
    real(kind=8) :: coord_crys_temp(3)

    natm_pc = size(pos_pc,1)
    do i = 1,natm_pc
        coord_crys_temp(:) = matmul(&
        pos_sc-pos_pc(i,1:3),recivec)
        if ((abs(coord_crys_temp(1)-idnint(coord_crys_temp(1)))<1d-4).and.&
            (abs(coord_crys_temp(2)-idnint(coord_crys_temp(2)))<1d-4).and.&
            (abs(coord_crys_temp(3)-idnint(coord_crys_temp(3)))<1d-4)) then
            idx = i
        end if
    end do

    end function get_pos_index_in_pc

    function fourier_transform(Ham,n,nb,G,R) result(Ham_f)

    ! Fourier transform of a block circualr matrix

    implicit none

    integer(kind=4),intent(in) :: n
    integer(kind=4),intent(in) :: nb
    real(kind=8),intent(in) :: G(3)
    real(kind=8),intent(in) :: R(3)
    complex(kind=8),intent(in) :: Ham(:,:)
    complex(kind=8) :: Ham_f(size(Ham,1),size(Ham,2))
    integer(kind=4) :: i,j,k,l
    integer(kind=4) :: na, mm

    na = n/nb
    Ham_f = 0.0d0

    do i = 1, nb
        do j = 1,nb
            Ham_f((i-1)*na+1:i*na,(i-1)*na+1:i*na) = &
            Ham_f((i-1)*na+1:i*na,(i-1)*na+1:i*na)+&
            Ham(1:na,(j-1)*na+1:j*na)*&
            exp(i_imag*dot_product(&
            G*dble(i-1)/dble(nb),&
            R*dble(j-1)))
        end do
    end do
    end function fourier_transform

    function decimation(Es_in0,e_in1,alpha_in,&
             beta_in,convergence) result(g)

    implicit none

    complex(kind=8),intent(in) :: Es_in0(:,:)
    complex(kind=8),intent(in) :: e_in1(:,:)
    complex(kind=8),intent(in) :: alpha_in(:,:)
    complex(kind=8),intent(in) :: beta_in(:,:)
    real(kind=8),intent(in) :: convergence
    complex(kind=8) :: Es0(size(Es_in0,1),size(Es_in0,2))
    complex(kind=8) :: e1(size(Es_in0,1),size(Es_in0,2))
    complex(kind=8) :: es(size(Es_in0,1),size(Es_in0,2))
    complex(kind=8) :: alpha(size(Es_in0,1),size(Es_in0,2))
    complex(kind=8) :: beta(size(Es_in0,1),size(Es_in0,2))
    complex(kind=8) :: ive(size(Es_in0,1),size(Es_in0,2))
    real(kind=8) :: maxdiff
    complex(kind=8) :: g(size(Es0,1),size(Es0,2))

    Es0 = Es_in0
    e1 = e_in1
    es = e_in1
    alpha = alpha_in
    beta = dconjg(transpose(alpha_in)) ! beta_in
    maxdiff = maxval(abs(alpha))
    do while( maxdiff .gt. convergence)
        ive = inv(Es0-e1)
        e1 = e1 + matmul(matmul(alpha,ive),beta)+&
                matmul(matmul(beta,ive),alpha)
        es = es + matmul(matmul(alpha,ive),beta)
        alpha = matmul(matmul(alpha,ive),alpha)
        beta = matmul(matmul(beta,ive),beta)
        maxdiff = maxval(abs(alpha))
    end do
    g = inv(Es0-es)

    end function decimation

    function gram_schmidt(U1) result(U2)

    implicit none
    complex(kind=8),intent(in) :: U1(:,:)
    complex(kind=8),dimension(size(U1,1),size(U1,2)) :: U2
    integer(kind=4) :: i,j,n

    U2 = U1
    n = size(U1,2)
    do i = 2,n
        do j=1,i-1
            U2(:,i) = U2(:,i) - &
             dot_product(U1(:,i),U2(:,j))/&
             dot_product(U2(:,j),U2(:,j))*&
             U2(:,j)
        end do
    end do

    do i = 1,n
        U2(:,i) = U2(:,i)/sqrt(dot_product(U2(:,i),U2(:,i)))
    end do

    end function

    function log_fbz(lambda,az) result(kz)

    implicit none
    complex(kind=8),intent(in) :: lambda
    real(kind=8),intent(in) :: az
    real(kind=8) :: kz, Gz

    Gz = 2*pi/az

    kz = modulo(real(log(lambda)/(i_imag*az)),Gz)
    if (kz.gt.Gz*0.5)then
        kz = kz - Gz ! make sure kz is inside fbz
    end if

    end function log_fbz

    function sorting(A) result(B)

    implicit none

    real(kind=8) :: A(:)
    real(kind=8) :: B(size(A,1))
    integer(kind=4) :: irow, nsize, krow
    real(kind=8) :: buf

    nsize = size(A,1)
    B = A
    do irow = 1, nsize
        krow = minloc(B(irow:nsize), dim=1) + irow - 1
        buf  = B(irow)
        B(irow) = B(krow)
        B(krow) = buf
    enddo
    end function sorting

    function sorting_index(A) result(I)

    implicit none

    real(kind=8) :: A(:)
    integer(kind=4) :: I(size(A,1))
    real(kind=8) :: B(size(A,1))
    real(kind=8) :: buf
    integer(kind=8) :: idx
    integer(kind=4) :: irow, nsize, krow

    nsize = size(A,1)
    B = A
    do irow = 1, nsize
        I(irow) = irow
    end do
    do irow = 1, nsize
        krow = minloc(B(irow:nsize), dim=1) + irow - 1
        buf  = B(irow)
        B(irow) = B(krow)
        B(krow) = buf
        idx  = I(irow)
        I(irow) = I(krow)
        I(krow) = idx
    enddo

    end function sorting_index

    function sorting_index_descent(A) result(I)

    implicit none

    real(kind=8) :: A(:)
    integer(kind=4) :: I(size(A,1))

    I = sorting_index(A)
    I = I(size(A,1):1:-1)

    end function sorting_index_descent

    function rotate_z(pos,ang) result(pos1)

    implicit none

    real(kind=8),intent(in)  :: pos(:,:)
    real(kind=8),intent(in)  :: ang
    integer(kind=4) :: nv
    real(kind=8)  :: pos1(size(pos,1),size(pos,2))
    integer(kind=4) :: i

    nv = size(pos,1)

    do i = 1,nv
        pos1(i,1) = pos(i,1)*cos(ang)-pos(i,2)*sin(ang)
        pos1(i,2) = pos(i,1)*sin(ang)+pos(i,2)*cos(ang)
        pos1(i,3) = pos(i,3)
    end do

    end function

    function rotate_z1(pos,ang) result(pos1)

    implicit none

    real(kind=8),intent(in)  :: pos(:)
    real(kind=8),intent(in)  :: ang
    integer(kind=4) :: nv
    real(kind=8)  :: pos1(size(pos,1))
    integer(kind=4) :: i

    nv = size(pos,1)

    pos1(1) = pos(1)*cos(ang)-pos(2)*sin(ang)
    pos1(2) = pos(1)*sin(ang)+pos(2)*cos(ang)
    pos1(3) = pos(3)

    end function

    function hermitian(A) result(B)

    implicit none

    complex(kind=8) :: A(:,:)
    complex(kind=8) :: B(size(A,1),size(A,2))

    B = 0.5*(A+transpose(dconjg(A)))

    end function hermitian

    function my_sqrt(M) result(N)

    implicit none

    real(kind=8) :: M(:)
    real(kind=8) :: N(size(M,1))
    integer(kind=4) :: i

    N = 0.0d0
    do i = 1,size(M,1)
       if (M(i) .lt.0.0d0) then
           N(i) = -sqrt(-M(i))
       else
           N(i) = sqrt(M(i))
       end if
    end do
    end function my_sqrt

    function find_min_dist(kpoint,n) result(kmin)

    implicit none

    real(kind=8) :: kpoint(:,:)
    integer(kind=4) :: n,i
    real(kind=8) :: kabs(n)
    real(kind=8) :: kmin(3)
    integer(kind=4) :: minid

    do i = 1,n
        kabs(i) = sqrt(dot_product(kpoint(i,:),kpoint(i,:)))
    end do

    minid = minloc(kabs,1)
    kmin = kpoint(minid,:)
    end function

    function bose_einstein(freq,temperature) result(fbe)

    implicit none

    real(kind=8) :: fbe
    real(kind=8) :: freq,temperature
    real(kind=8) :: expf

    expf = exp(hbar*freq*1.0d12*2*pi/kb/temperature)

    fbe = 1.0d0/(expf-1.0d0)

    end function

    function dbosedT(freq,temperature) result(fbe)

    implicit none

    real(kind=8) :: fbe
    real(kind=8) :: freq,temperature
    real(kind=8) :: expf

    expf = exp(hbar*freq*1.0d12*2*pi/kb/temperature)

    fbe = expf/(expf-1.0d0)**2*hbar*freq*1.0d12*2*pi/kb/temperature**2

    end function

    function simpson(x,y) result(f)

    implicit none

    real(kind=8) :: x(:),dx
    complex(kind=8) :: y(:)
    complex(kind=8) :: f
    integer(kind=4) :: n,i,mm

    n = size(x,1)
    dx = x(n)-x(n-1)
    f = 0.0d0
    if (mod(n-1,2) .eq.0) then
        mm = (n-1)/2
        f = f + y(1)
        do i = 1,mm
            f = f + 4.0d0*y(2*i)
        end do
        do i = 1,mm-1
            f = f + 2.0d0*y(2*i+1)
        end do
        f = f + y(n)
    else
        write(*,*) "ne should be an odd number"
        stop

    end if
    f = f*dx/3.0d0
    end function

end module util


      SUBROUTINE solver(amat, b, m, nrhs, info)
      USE stel_kinds
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER, INTENT(in)  :: m, nrhs
      INTEGER, INTENT(out) :: info
      REAL(rprec), INTENT(inout) :: amat(m,m), b(m,nrhs)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER, ALLOCATABLE :: ipiv(:)
C-----------------------------------------------
      info = 0
      ALLOCATE (ipiv(m))

!     Compute the solution to a REAL system of linear equations
!       AMAT * X = B,
!     WHERE AMAT is an M-by-M matrix and X and B are N-by-NRHS matrices.
!
!     FACTOR AMATRIX INTO LU FORM
!     AND SOLVE BY GAUSSIAN ELIMINATION
!
      CALL dgesv (m, nrhs, amat, m, ipiv, b, m, info)
!     IF (info .ne. 0) PRINT *, ' Condition No. = 0 in Solver'

      DEALLOCATE (ipiv)

      END SUBROUTINE solver


!===============================================================================
!> Module for Lagrange interpolation
!===============================================================================
MODULE lagrange_mod
  USE io_mod
  USE trace_mod
  implicit none
  private
  type, public:: lagrange_t
    integer:: verbose=0
    integer:: order=2
    logical:: initialized=.false.
  contains
    procedure interpolation4
    procedure interpolation8
    generic:: interpolation => interpolation4, interpolation8
    procedure sequence4
    procedure sequence8
    generic:: sequence => sequence4, sequence8
    procedure interval4
    procedure interval8
    generic:: interval => interval4, interval8
    procedure weights4
    procedure weights8
    generic:: weights => weights4, weights8
    procedure deriv_weights4
    procedure deriv_weights8
    generic:: deriv_weights => deriv_weights4, deriv_weights8
    procedure deriv2_weights4
    procedure deriv2_weights8
    generic:: deriv2_weights => deriv2_weights4, deriv2_weights8
    procedure sequence_weights4
    procedure sequence_weights8
    generic:: sequence_weights => sequence_weights4, sequence_weights8
    procedure deriv_sequence_weights4
    procedure deriv_sequence_weights8
    generic:: deriv_sequence_weights => deriv_sequence_weights4, deriv_sequence_weights8
    procedure deriv2_sequence_weights4
    procedure deriv2_sequence_weights8
    generic:: deriv2_sequence_weights => deriv2_sequence_weights4, deriv2_sequence_weights8
    procedure interpolate3d
    procedure trilinear3d
    procedure test
    procedure debug
    procedure init
    procedure interpolate1d4
    procedure interpolate1d8
    generic:: interpolate1d => interpolate1d4, interpolate1d8
  end type
  type(lagrange_t), public:: lagrange
CONTAINS

!> -----------------------------------------------------------------------------
!> Classical Lagrange interpolation
!> -----------------------------------------------------------------------------
FUNCTION interpolation4 (self, x0, x, y) RESULT(f)
  class(lagrange_t):: self
  real(kind=4), dimension(:):: x, y
  real(kind=4):: x0, f, g
  integer:: n, i, j
  !.............................................................................
  f = 0.0
  n = size(x)
  do i=1,n
    g = y(i)
    do j=1,n
      g = merge(g,g*(x0-x(j))/(x(i)-x(j)),j==i)
    end do
    f = f + g
  end do
END FUNCTION interpolation4
FUNCTION interpolation8 (self, x0, x, y) RESULT(f)
  class(lagrange_t):: self
  real(kind=8), dimension(:):: x, y
  real(kind=8):: x0, f, g
  integer:: n, i, j
  !.............................................................................
  f = 0.0
  n = size(x)
  do i=1,n
    g = y(i)
    do j=1,n
      g = merge(g,g*(x0-x(j))/(x(i)-x(j)),j==i)
    end do
    f = f + g
  end do
END FUNCTION interpolation8

!> -----------------------------------------------------------------------------
!> Classical Lagrange interpolation weights.  w(i) is the contribution factor
!> of a value y(i) to the function value at x0, given that there are mesh points
!> at x = [x(j), j=1,n], so the function value f(x0) = sum(y(i)*w(i))
!> -----------------------------------------------------------------------------
FUNCTION weights4 (self, x0, x) RESULT(w)
  class(lagrange_t):: self
  real(kind=4), dimension(:):: x
  real(kind=4), dimension(size(x)):: w
  real(kind=4):: x0, g
  integer:: n, i, j
  !.............................................................................
  n = size(x)
  do i=1,n
    w(i) = 1.0
    do j=1,n
      if (j==i) cycle
      if (x(j)==x(i)) then
        w = 0.0
        w(1) = 1.0
        return
      end if
      w(i) = w(i)*(x0-x(j))/(x(i)-x(j))
    end do
  end do
END FUNCTION weights4
FUNCTION weights8 (self, x0, x) RESULT(w)
  class(lagrange_t):: self
  real(kind=8), dimension(:):: x
  real(kind=8), dimension(size(x)):: w
  real(kind=8):: x0, g
  integer:: n, i, j
  !.............................................................................
  n = size(x)
  do i=1,n
    w(i) = 1.0
    do j=1,n
      if (j==i) cycle
      if (x(j)==x(i)) then
        w = 0d0
        w(1) = 1d0
        return
      end if
      w(i) = w(i)*(x0-x(j))/(x(i)-x(j))
    end do
  end do
END FUNCTION weights8

!> -----------------------------------------------------------------------------
!> Classical Lagrange interpolation weights.  w(i) is the contribution factor
!> of a value y(i) to the derivative value at x0, given that there are mesh
!> points at x = [x(j), j=1,n], so the function value f(x0) = sum(y(i)*w(i))
!> -----------------------------------------------------------------------------
FUNCTION deriv_weights4 (self, x0, x) RESULT(w)
  class(lagrange_t):: self
  real(kind=4), dimension(:):: x
  real(kind=4), dimension(size(x)):: w
  real(kind=4):: x0, nomin, denom, g
  integer:: n, i, j, k
  !.............................................................................
  n = size(x)
  do i=1,n
    denom = 1.0_4
    nomin = 0.0_4
    do j=1,n
      if (j==i) cycle
      if (x(i)==x(j)) then
        w = 0.0
        return
      end if
      g = 1.
      do k=1,n
        if (k==j .or. k==i) cycle
        g = g*(x0-x(k))
      end do
      nomin = nomin + g
      denom = denom*(x(i)-x(j))
    end do
    w(i) = nomin/denom
  end do
END FUNCTION deriv_weights4
FUNCTION deriv_weights8 (self, x0, x) RESULT(w)
  class(lagrange_t):: self
  real(kind=8), dimension(:):: x
  real(kind=8), dimension(size(x)):: w
  real(kind=8):: x0, nomin, denom, g
  integer:: n, i, j, k
  !.............................................................................
  n = size(x)
  do i=1,n
    denom = 1.0_8
    nomin = 0.0_8
    do j=1,n
      if (j==i) cycle
      if (x(i)==x(j)) then
        w = 0.0_8
        return
      end if
      g = 1.0_8
      do k=1,n
        if (k==j .or. k==i) cycle
        g = g*(x0-x(k))
      end do
      nomin = nomin + g
      denom = denom*(x(i)-x(j))
    end do
    w(i) = nomin/denom
  end do
END FUNCTION deriv_weights8

!> -----------------------------------------------------------------------------
!> Classical Lagrange interpolation weights.  w(i) is the contribution factor
!> of a value y(i) to the 2nd derivative value at x0, given that there are mesh
!> points at x = [x(j), j=1,n], so the function value f(x0) = sum(y(i)*w(i))
!> -----------------------------------------------------------------------------
FUNCTION deriv2_weights4 (self, x0, x) RESULT(w)
  class(lagrange_t):: self
  real(kind=4), dimension(:):: x
  real(kind=4), dimension(size(x)):: w
  real(kind=4):: x0, nomin, denom, g
  integer:: n, i, j, k, l
  !.............................................................................
  n = size(x)
  do i=1,n
    denom = 1.0_4
    nomin = 0.0_4
    do j=1,n
      if (j==i) cycle
      if (x(i)==x(j)) then
        w = 0.0
        return
      end if
      do k=1,n
        if (k==j .or. k==i) cycle
        g = 1.
        do l=1,n
          if (l==k .or. l==j .or. l==i) cycle
          g = g*(x0-x(l))
        end do
        nomin = nomin + g
      end do
      denom = denom*(x(i)-x(j))
    end do
    w(i) = nomin/denom
  end do
END FUNCTION deriv2_weights4
FUNCTION deriv2_weights8 (self, x0, x) RESULT(w)
  class(lagrange_t):: self
  real(kind=8), dimension(:):: x
  real(kind=8), dimension(size(x)):: w
  real(kind=8):: x0, nomin, denom, g
  integer:: n, i, j, k, l
  !.............................................................................
  n = size(x)
  do i=1,n
    denom = 1.0_8
    nomin = 0.0_8
    do j=1,n
      if (j==i) cycle
      if (x(i)==x(j)) then
        w = 0.0_8
        return
      end if
      do k=1,n
        if (k == j .or. k == i) cycle
        g = 1.0_8
        do l=1,n
          if (l == k .or. l == j .or. l == i) cycle
          g = g*(x0-x(l))
        end do
        nomin = nomin + g
      end do
      denom = denom*(x(i)-x(j))
    end do
    w(i) = nomin/denom
  end do
END FUNCTION deriv2_weights8

!> -----------------------------------------------------------------------------
!> Prepare to use Lagrange interpolation of given order to interpolate to
!> coordinate x0 in a sequence that may be longer than needed
!> -----------------------------------------------------------------------------
SUBROUTINE interval4 (self, x0, x, i0, i2, o, order)
  class(lagrange_t):: self
  integer, optional:: order
  real(kind=4), dimension(:):: x
  real(kind=4), dimension(size(x)):: y
  real(kind=4):: x0, f
  integer:: i0, i1, i2, o, n
  !.............................................................................
  ! Default order = 3, or n-1 if that is smaller
  n = size(x)
  o = 3
  if (present(order)) o = order
  o = min(o,n-1)
  ! Search for identical initial points
  i1 = 1
  do while (x(i1)==x(1) .and. i1<n)
    i1 = i1+1
  end do
  ! All points are equal to x(1)
  if (x(i1)==x(1)) then
    i0 = 1
    i2 = 1
    o = 0
    return
  ! Only the last point is not equal to x(1)
  else if (i1==n) then
    i0 = n-1
    i2 = n
    o = 1
    return
  end if
  ! Normal search
  do while (x(i1)<x0 .and. i1<n)
    i1 = i1+1
  end do
  if (i1 < 3 .or. i1 > n-1) then
    o = min(o,2)
  end if

  if (i1 < 2+o/2) then
    ! We are at the start of the interval, and need 1 point before i1
    i0 = i1 - (o+1)/2
    if (i0 < 1) then
      i0 = 1
    end if
    i2 = i0+o
    if (i2 > n) then
      i2 = n
      o = min(o,i2-i0)
    end if
  else
    ! We are in the middle or end of the interval
    i2 = i1 + (o-1)/2
    ! Shift left if not enough points
    if (i2 > n) then
      i2 = n
    end if
    i0 = i2 - o
    if (i0 < 1) then
      i0 = 1
      i2 = min(i2,n)
      o = min(o,i2-i0)
    end if
  end if
  if (self%verbose>0) then
    print*,'lagrange_interval: i0, i2, o =', i0, i2, o
  end if
END SUBROUTINE interval4
SUBROUTINE interval8 (self, x0, x, i0, i2, o, order)
  class(lagrange_t):: self
  integer, optional:: order
  real(kind=8), dimension(:):: x
  real(kind=8), dimension(size(x)):: y
  real(kind=8):: x0, f
  integer:: i0, i1, i2, o, n
  !.............................................................................
  ! Default order = 3, or n-1 if that is smaller
  n = size(x)
  o = 3
  if (present(order)) o = order
  o = min(o,n-1)
  ! Search for identical initial points
  i1 = 1
  do while (x(i1)==x(1) .and. i1<n)
    i1 = i1+1
  end do
  ! All points are equal to x(1)
  if (x(i1)==x(1)) then
    i0 = 1
    i2 = 1
    o = 0
    return
  ! Only the last point is not equal to x(1)
  else if (i1==n) then
    i0 = n-1
    i2 = n
    o = 1
    return
  end if
  ! Normal search
  do while (x(i1)<x0 .and. i1<n)
    i1 = i1+1
  end do
  if (i1 < 3 .or. i1 > n-1) then
    o = min(o,2)
  end if

  if (i1 < 2+o/2) then
    ! We are at the start of the interval, and need 1 point before i1
    i0 = i1 - (o+1)/2
    if (i0 < 1) then
      i0 = 1
    end if
    i2 = i0+o
    if (i2 > n) then
      i2 = n
      o = min(o,i2-i0)
    end if
  else
    ! We are in the middle or end of the interval
    i2 = i1 + (o-1)/2
    ! Shift left if not enough points
    if (i2 > n) then
      i2 = n
    end if
    i0 = i2 - o
    if (i0 < 1) then
      i0 = 1
      i2 = min(i2,n)
      o = min(o,i2-i0)
    end if
  end if
  if (self%debug(1)) then
    print '("lagrange_interval: i0,i2:",2i3,3x,"o:",i2,3x,"x0:",f10.6,3x,"x:",10f10.6)', &
                                i0,i2,          o,         x0,           x
  end if
END SUBROUTINE interval8

!> -----------------------------------------------------------------------------
!> Use Lagrange interpolation of given order to interpolate to coordinate x0
!> in a sequence that may be longer than needed
!> -----------------------------------------------------------------------------
FUNCTION sequence4 (self, x0, x, y, order, correct) RESULT(f)
  class(lagrange_t):: self
  integer, optional:: order
  real(kind=4), optional:: correct
  real(kind=4), dimension(:):: x, y
  real(kind=4):: x0, f
  integer:: i0, i2, o, n
  !.............................................................................
  n = size(x)
  call self%interval (x0, x, i0, i2, o, order)
  if (self%verbose>0) then
    print'(" i0,i2,order=",3i3,4x,"x0,x,y  =",1p,18g12.4)', &
      i0, i2, o, x0, x(i0:i2), y(i0:i2)
  end if
  f = self%interpolation (x0, x(i0:i2), y(i0:i2))
  if (self%verbose>0) then
    if (present(correct)) then
      print'(" i0,i2,order=",3i3,4x,"x0,x,y,f,correct=",1p,18g12.4)', &
        i0, i2, o, x0, x(i0:i2), y(i0:i2), f, correct
    else
      print'(" i0,i2,order=",3i3,4x,"x0,x,y,f=",1p,18g12.4)', &
        i0, i2, o, x0, x(i0:i2), y(i0:i2), f
    end if
  end if
END FUNCTION sequence4
FUNCTION sequence8 (self, x0, x, y, order, correct) RESULT(f)
  class(lagrange_t):: self
  integer, optional:: order
  real(kind=8), optional:: correct
  real(kind=8), dimension(:):: x, y
  real(kind=8):: x0, f
  integer:: i0, i2, o, n
  !.............................................................................
  n = size(x)
  call self%interval (x0, x, i0, i2, o, order)
  if (self%verbose>0) then
    print'(" i0,i2,order=",3i3,4x,"x0,x,y  =",1p,18g12.4)', &
      i0, i2, o, x0, x(i0:i2), y(i0:i2)
  end if
  f = self%interpolation (x0, x(i0:i2), y(i0:i2))
  if (self%verbose>0) then
    if (present(correct)) then
      print'(" i0,i2,order=",3i3,4x,"x0,x,y,f,correct=",1p,18g12.4)', &
        i0, i2, o, x0, x(i0:i2), y(i0:i2), f, correct
    else
      print'(" i0,i2,order=",3i3,4x,"x0,x,y,f=",1p,18g12.4)', &
        i0, i2, o, x0, x(i0:i2), y(i0:i2), f
    end if
  end if
END FUNCTION sequence8

!> -----------------------------------------------------------------------------
!> Use Lagrange interpolation of given order to get weights for interpolate to
!> coordinate x0 in a sequence of increasing x that may be longer than needed
!> -----------------------------------------------------------------------------
SUBROUTINE sequence_weights4 (self, x0, x, i0, i2, w, order)
  class(lagrange_t):: self
  integer, optional:: order
  real(kind=4), dimension(:):: x, w
  real(kind=4):: x0
  integer:: i0, i2, o, n
  !.............................................................................
  n = size(x)
  call self%interval (x0, x, i0, i2, o, order)
  w = 0d0
  if (o==0) then
    w(1) = 1.0
  else
    w(1:i2-i0+1) = self%weights (x0, x(i0:i2))
  end if
END SUBROUTINE sequence_weights4
SUBROUTINE sequence_weights8 (self, x0, x, i0, i2, w, order)
  class(lagrange_t):: self
  integer, optional:: order
  real(kind=8), dimension(:):: x, w
  real(kind=8):: x0
  integer:: i0, i2, o, n
  !.............................................................................
  n = size(x)
  call self%interval (x0, x, i0, i2, o, order)
  w = 0d0
  if (o==0) then
    w(1) = 1.0
  else
    w(1:i2-i0+1) = self%weights (x0, x(i0:i2))
  end if
END SUBROUTINE sequence_weights8

!> -----------------------------------------------------------------------------
!> Use Lagrange interpolation of given order to get weights for interpolate to
!> coordinate x0 in a sequence of increasing x that may be longer than needed
!> -----------------------------------------------------------------------------
SUBROUTINE deriv_sequence_weights4 (self, x0, x, i0, i2, w, order)
  class(lagrange_t):: self
  integer, optional:: order
  real(kind=4), dimension(:):: x, w
  real(kind=4):: x0
  integer:: i0, i2, o, n
  !.............................................................................
  n = size(x)
  call self%interval (x0, x, i0, i2, o, order)
  w = 0d0
  w(1:i2-i0+1) = self%deriv_weights (x0, x(i0:i2))
END SUBROUTINE deriv_sequence_weights4
SUBROUTINE deriv_sequence_weights8 (self, x0, x, i0, i2, w, order)
  class(lagrange_t):: self
  integer, optional:: order
  real(kind=8), dimension(:):: x, w
  real(kind=8):: x0
  integer:: i0, i2, o, n
  !.............................................................................
  n = size(x)
  call self%interval (x0, x, i0, i2, o, order)
  w = 0d0
  w(1:i2-i0+1) = self%deriv_weights (x0, x(i0:i2))
END SUBROUTINE deriv_sequence_weights8

!> -----------------------------------------------------------------------------
!> Use Lagrange interpolation of given order to get weights for interpolate to
!> coordinate x0 in a sequence of increasing x that may be longer than needed
!> -----------------------------------------------------------------------------
SUBROUTINE deriv2_sequence_weights4 (self, x0, x, i0, i2, w, order)
  class(lagrange_t):: self
  integer, optional:: order
  real(kind=4), dimension(:):: x, w
  real(kind=4):: x0
  integer:: i0, i2, o, n
  !.............................................................................
  n = size(x)
  call self%interval (x0, x, i0, i2, o, order)
  w = 0d0
  w(1:i2-i0+1) = self%deriv2_weights (x0, x(i0:i2))
END SUBROUTINE deriv2_sequence_weights4
SUBROUTINE deriv2_sequence_weights8 (self, x0, x, i0, i2, w, order)
  class(lagrange_t):: self
  integer, optional:: order
  real(kind=8), dimension(:):: x, w
  real(kind=8):: x0
  integer:: i0, i2, o, n
  !.............................................................................
  n = size(x)
  call self%interval (x0, x, i0, i2, o, order)
  w = 0d0
  w(1:i2-i0+1) = self%deriv2_weights (x0, x(i0:i2))
END SUBROUTINE deriv2_sequence_weights8

!> -----------------------------------------------------------------------------
!> Interpolate in 3D from fi to fo
!> -----------------------------------------------------------------------------
SUBROUTINE interpolate3d (self, xi, yi, zi, fi, xo, yo, zo, fo, order)
  class(lagrange_t):: self
  real, dimension(:):: xi, yi, zi, xo, yo, zo
  real, dimension(:,:,:):: fi, fo
  integer:: order
  !.............................................................................
  real, dimension(:,:,:), pointer:: f1, f2
  integer:: nix, niy, niz, nox, noy, noz, ix, iy, iz
  !-----------------------------------------------------------------------------
  nix = size(xi)
  niy = size(yi)
  niz = size(zi)
  nox = size(xo)
  noy = size(yo)
  noz = size(zo)
  allocate (f1(nix,niy,noz))
  do iz=1,noz
  do iy=1,niy
  do ix=1,nix
    f1(ix,iy,iz) = self%sequence (zo(iz), zi, fi(ix,iy,:), order)
  end do
  end do
  end do
  allocate (f2(nix,noy,noz))
  do iz=1,noz
  do iy=1,noy
  do ix=1,nix
    f2(ix,iy,iz) = self%sequence (yo(iy), yi, f1(ix,:,iz), order)
  end do
  end do
  end do
  deallocate (f1)
  do iz=1,noz
  do iy=1,noy
  do ix=1,nox
    fo(ix,iy,iz) = self%sequence (xo(ix), xi, f2(:,iy,iz), order)
  end do
  end do
  end do
  deallocate (f2)
END SUBROUTINE interpolate3d

!> -----------------------------------------------------------------------------
!> Interpolate in 3D from fi to fo
!> -----------------------------------------------------------------------------
SUBROUTINE trilinear3d (self, xi, yi, zi, fi, xo, yo, zo, fo, order)
  class(lagrange_t):: self
  real, dimension(:):: xi, yi, zi, xo, yo, zo
  real, dimension(:,:,:):: fi, fo
  integer:: order
  !.............................................................................
  integer:: nix, niy, niz, nox, noy, noz, ix, iy, iz, jx ,jy, jz
  real:: px, py, pz, qx, qy, qz, dx, dy, dz
  !-----------------------------------------------------------------------------
  nix = size(xi)
  niy = size(yi)
  niz = size(zi)
  nox = size(xo)
  noy = size(yo)
  noz = size(zo)
  dx = (xi(nix)-xi(1))/(nix-1)
  dy = (yi(niy)-yi(1))/(niy-1)
  dz = (zi(niz)-zi(1))/(niz-1)
  do iz=1,noz
    do jz=1,niz-2
      if (zi(jz+1)>zo(iz)) exit
    end do
    pz = (zo(iz)-zi(jz))/(zi(jz+1)-zi(jz))
    pz = max(0.0,min(1.0,pz))
    qz = 1.0-pz
    do iy=1,noy
      py = (yo(iy)-yi(1))/dy + 1.
      jy = py
      jy = max(1,min(niy-1,jy))
      py = max(0.0,min(1.0,py -jy))
      qy = 1.0-py
      do ix=1,nox
        px = (xo(ix)-xi(1))/dx + 1.
        jx = px
        jx = max(1,min(nix-1,jx))
        px = max(0.0,min(1.0,px -jx))
        qx = 1.0-px
        fo(ix,iy,iz) = &
          qz*(qy*(qx*fi(jx  ,jy  , jz  ) + px*fi(jx+1,jy  , jz  )) + &
              py*(qx*fi(jx  ,jy+1, jz  ) + px*fi(jx+1,jy+1, jz  ))) + &
          pz*(qy*(qx*fi(jx  ,jy  , jz+1) + px*fi(jx+1,jy  , jz+1)) + &
              py*(qx*fi(jx  ,jy+1, jz+1) + px*fi(jx+1,jy+1, jz+1)))
      end do
    end do
  end do
END SUBROUTINE trilinear3d

!> -----------------------------------------------------------------------------
!> Test for a polynomial of order 2
!> -----------------------------------------------------------------------------
SUBROUTINE test (self)
  class(lagrange_t):: self
  integer, parameter:: n=5
  integer:: order, i, i0, i1
  real(8), dimension(n):: x, y, w
  real(8):: x0, y0
  !-----------------------------------------------------------------------------
  if (.not. io_unit%master) return
  print *,'--------------- lagrange_t%test ------------------'
  x = 0.0
  y = 1.0
  order = 1
  print '(5x,a,11x,a,11x,a,4x,a)', 'x', 'y', 'y==1', 'order'
  do i=1,n+1
    x0 = i-0.5
    call self%sequence_weights (x0, x, i0, i1, w, order)
    y0 = sum(y(i0:i1)*w(1:1+i1-i0))
    print '(3g12.4,i6)', x0, y0, x0**order, i1-i0
  end do
  y = 0.0
  x(n) = 1.0
  y(n) = 1.0
  print '(5x,a,11x,a,11x,a,4x,a)', 'x', 'y', 'x-4', 'order'
  do i=1,n+1
    x0 = i-0.5
    call self%sequence_weights (x0, x, i0, i1, w, order)
    y0 = sum(y(i0:i1)*w(1:1+i1-i0))
    print '(3g12.4,i6)', x0, y0, x0**order, i1-i0
  end do
  order = 2
  do i=1,n
    x(i) = i
    y(i) = x(i)**order
  end do
  print '(5x,a,11x,a,11x,a,4x,a)', 'x', 'y', 'x**2', 'order'
  do i=1,n+1
    x0 = i-0.5
    call self%sequence_weights (x0, x, i0, i1, w, order)
    y0 = sum(y(i0:i1)*w(1:1+i1-i0))
    print '(3g12.4,i6)', x0, y0, x0**order, i1-i0
  end do
  print *,'--------------------------------------------------'
END SUBROUTINE test

!> -----------------------------------------------------------------------------
!> -----------------------------------------------------------------------------
FUNCTION debug (self, verbose)
  class(lagrange_t):: self
  integer:: verbose
  logical:: debug
  !-----------------------------------------------------------------------------
  if (.not.self%initialized) call self%init
  debug = (self%verbose >= verbose)
END FUNCTION debug

!> -----------------------------------------------------------------------------
!> Initialize (only) this instance of lagrange
!> -----------------------------------------------------------------------------
SUBROUTINE init (self)
  class(lagrange_t):: self
  integer:: iostat
  integer:: verbose=0, order=2
  namelist /lagrange_params/ verbose, order
  !-----------------------------------------------------------------------------
  call trace%begin ('lagrange_t%init')
  !$omp critical (input_cr)
  if (.not.self%initialized) then
    self%initialized = .true.
    rewind (io_unit%input)
    read (io_unit%input, lagrange_params, iostat=iostat)
    if (io_unit%master) write (io_unit%output, lagrange_params)
    self%verbose = verbose
    self%order = order
  end if
  !$omp end critical (input_cr)
  call trace%end ()
END SUBROUTINE init

!> =============================================================================
!> Use default 1-D Lagrange interpolation
!> =============================================================================
FUNCTION interpolate1d4 (self,x0, n, x, y) RESULT(f)
  class(lagrange_t):: self
  integer:: n
  real(kind=4):: x0, x(n), y(n), f
  !.............................................................................
  if (x0 < x(1)) then
    f = y(1)
  else if (x0 > x(n)) then
    f = y(n)
  else
    f = self%sequence (x0, x, y)
  end if
END FUNCTION interpolate1d4

FUNCTION interpolate1d8 (self,x0, n, x, y) RESULT(f)
  class(lagrange_t):: self
  integer:: n
  real(kind=8):: x0, x(n), y(n), f
  !.............................................................................
  if (x0 < x(1)) then
    f = y(1)
  else if (x0 > x(n)) then
    f = y(n)
  else
    f = self%sequence (x0, x, y)
  end if
END FUNCTION interpolate1d8

END MODULE


! THIS VERSION: GALAHAD 2.1 - 22/03/2007 AT 09:00 GMT.
      program SILS_test_deck
      use GALAHAD_SILS_double
      implicit none
      type(SMT_type) matrix
      type(SILS_control) cntl
      type(SILS_ainfo) ainfo
      type(SILS_finfo) finfo
      type(SILS_sinfo) sinfo
      type(SILS_factors) factors

      double precision, allocatable :: b(:,:),x(:,:),d(:,:),bb(:),xx(:),pert(:)
      integer, allocatable :: perm(:),pivots(:),ip(:),iw(:)
      integer i,info,jj,j1,j2,kase,n,ne,ne1,nrhs

      EXTERNAL YM01AD

      do kase = 0,5
! Read matrix order and number of entries
        READ(5,*) n,ne
        matrix%n = n
        matrix%ne = ne
! Allocate matrix arrays
        allocate(matrix%val(ne), matrix%row(ne), matrix%col(ne))
        nrhs = 1
        IF (kase .le. 3) THEN
          IF (kase .eq. 1) THEN
            nrhs = 2
            allocate (perm(n))
          ENDIF
          IF (kase.eq.2) THEN
            n = n + 1
            matrix%n = n
          ENDIF

! Allocate arrays of appropriate sizes
          IF (kase .eq. 1)  THEN
            allocate(b(n,nrhs), x(n,nrhs), pivots(n))
          ELSE
            allocate(bb(n), xx(n), d(2,n), pivots(n))
          ENDIF

          IF (kase .eq. 0) allocate(pert(n))

! Read matrix and right-hand side
          READ(5,*) (matrix%row(I),matrix%col(I),matrix%val(I),I=1,ne)
          IF (kase.eq.1) THEN
            READ(5,*) b(:,1)
            b(:,2) = b(:,1)
          ENDIF
          IF (kase.eq.2) THEN
            READ(5,*) bb(1:n-1)
            bb(n) = 1.23456789
            xx = bb
          ENDIF
        ELSE
          allocate(bb(n), xx(n), d(2,n), pivots(n))
          allocate(ip(n+1),iw(2*n))
          ne1 = ne
          CALL YM01AD(n,n,ne1,ne,-1,2,.true.,matrix%row,matrix%val,ip,iw)
          do i=1,n
            xx(i) = 1.0
            j1=ip(i)
            j2=ip(i+1)-1
            do jj=j1,j2
              matrix%col(jj)=i
! Set diagonal to zero
              IF (i==matrix%row(jj)) matrix%val(jj) = 0.0
            enddo
          enddo
          deallocate(ip,iw)
        ENDIF

! Initialize the structures
        IF (kase.lt.5) CALL SILS_initialize(factors,cntl)
        IF (kase.eq.0) cntl%pivoting = 4

! Analyse
        CALL SILS_analyse(matrix,factors,cntl,ainfo)

        IF(ainfo%flag<0) THEN
           WRITE(6,'(A,I2)') &
              'Failure of SILS_analyse with ainfo%flag=', ainfo%flag
           STOP
        END IF

! Recall analyse using input pivot sequence
        IF (kase.eq.1) THEN
          CALL SILS_enquire(factors,perm)
          CALL SILS_analyse(matrix,factors,cntl,ainfo,perm)

          IF(ainfo%flag<0) THEN
             WRITE(6,'(A,I2)') &
              'Failure of SILS_analyse with ainfo%flag=', ainfo%flag
             STOP
          END IF
        ENDIF

        IF (kase.eq.3) matrix%n = matrix%n + 1

! Factorize matrix
        CALL SILS_factorize(matrix,factors,cntl,finfo)
        IF(finfo%flag<0) THEN
           WRITE(6,'(A,I2)') &
              'Failure of SILS_factorize with finfo%flag=', finfo%flag
           go to 50
        END IF

        IF (kase.eq.0) THEN
! Check perturbation enquiry
          CALL SILS_enquire(factors,perturbation=pert)
          WRITE(6,'(A/(5G16.8))') 'Schnabel-Eskow permutation',pert
          go to 50
        ENDIF

        IF (kase.eq.1) THEN
          x = b
! Solve without refinement (2 rhs)
          CALL SILS_solve(matrix,factors,x,cntl,sinfo)
          IF(sinfo%flag.eq.0)WRITE(6,'(/A,/,(3G24.16))')  &
             'Solution without refinement is',x

          x = b
          CALL SILS_part_solve(factors,cntl,'L',x,info)
          WRITE(6,'(/a,/,(3G24.16))')'Solution after L is',x
          CALL SILS_part_solve(factors,cntl,'D',x,info)
          WRITE(6,'(a,/,(3G24.16))')'Solution after D is',x
          CALL SILS_part_solve(factors,cntl,'U',x,info)
          WRITE(6,'(a,/,(3G24.16))')'Solution after U is',x

! Perform one refinement
          CALL SILS_solve(matrix,factors,x,cntl,sinfo,b)
          IF(sinfo%flag.eq.0)WRITE(6,'(/A,/,(3G24.16))') &
              'Solution after one refinement is',x

      ELSE

! One rhs

          CALL SILS_solve(matrix,factors,xx,cntl,sinfo)
          IF(sinfo%flag.eq.0 .and. kase.le.3) WRITE(6,'(/A,/,(3G24.16))')  &
             'Solution without refinement is',xx

          IF (kase.gt.2) GO TO 50

          xx = bb
          CALL SILS_part_solve(factors,cntl,'L',xx,info)
          WRITE(6,'(/a,/,(3G24.16))')'Solution after L is',xx
          CALL SILS_part_solve(factors,cntl,'D',xx,info)
          WRITE(6,'(a,/,(3G24.16))')'Solution after D is',xx
          CALL SILS_part_solve(factors,cntl,'U',xx,info)
          WRITE(6,'(a,/,(3G24.16))')'Solution after U is',xx

! Perform one refinement
          CALL SILS_solve(matrix,factors,xx,cntl,sinfo,bb)
          WRITE(6,'(/a,/,(3G24.16))')'Solution with refinement is',xx

          CALL SILS_enquire(factors,pivots=pivots,d=d)
          WRITE(6,'(/a)')'Pivots and D:'
          i = 1
          do
           IF (i>n) exit
           IF (pivots(i)>0) THEN
              WRITE(6,'(i5,f10.5)') pivots(i), d(1,i)
              i = i + 1
            ELSE
              WRITE(6,'(i5,2f10.5)') pivots(i), d(1:2,i)
              WRITE(6,'(i5,2f10.5)') pivots(i+1), d(2,i), d(1,i+1)
              i = i + 2
            END IF
          end do

          d(1,:) = 1
          CALL SILS_alter_d(factors,d,i)
          IF (i==0) WRITE(6,'(/a)')'Successful call of SILS_alter_d'
          CALL SILS_enquire(factors,pivots=pivots,d=d)
          WRITE(6,'(a)')'Pivots and altered D:'
          i = 1
          do
           IF (i>n) exit
           IF (pivots(i)>0) THEN
              WRITE(6,'(i5,f10.5)') pivots(i), d(1,i)
              i = i + 1
            ELSE
              WRITE(6,'(i5,2f10.5)') pivots(i), d(1:2,i)
              WRITE(6,'(i5,2f10.5)') pivots(i+1), d(2,i), d(1,i+1)
              i = i + 2
            END IF
          end do

        ENDIF

! Deallocate arrays
  50    IF (kase.ne.4) CALL SILS_finalize(factors,cntl,info)
        deallocate(matrix%val, matrix%row, matrix%col)
        IF (kase .eq. 1) THEN
! Deallocate arrays for second pass
          deallocate(pivots,b,x)
        ELSE
! Deallocate arrays for next pass
          deallocate(pivots,bb,xx,d)
        ENDIF

      enddo

      END program SILS_test_deck


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!!!!!!!residual for Laplace eqn!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine  blockgmres_Laplace(xloc,I_fluid,p_inter,ien,lp_el,count_el)
  use global_constants
  use run_variables
  use fluid_variables
  implicit none

  integer ien(nen,ne)
  real(8) xloc(nsd,nn)
  real(8) I_fluid(nn)
  real(8) p_inter(nn)
!  real(8) w_inter(nn)
!---------------------
  integer count_el
  integer lp_el(count_el)
!---------------------
  real(8) x(nsd,nen),d(nen)
  real(8) eft0,det,effd,effm,effc
  real(8) sh(0:nsd,nen),ph(0:nsd,nen)
  real(8) xr(nsd,nsd),cf(nsd,nsd),sx(nsd,nsd)

  real(8) dr(nsd)

  integer inl,ie,isd,node,iq
  integer je
!==============================================================
  do je=1,count_el     !loop over elements
	ie=lp_el(je)
!   do ie=1,ne
     do inl=1,nen
	x(1:nsd,inl) = xloc(1:nsd,ien(inl,ie))
	d(inl) = I_fluid(ien(inl,ie))
     end do

     do iq=1,nquad  ! loop over the quadrature points in each element
!!!!!!!!!!!!!!!!!!!!calculate shape function!!!!!!!!!!!!!!!!!!!!!!!!!!
	if (nsd==2) then
	   if(nen.eq.3) then
		include 'sh2d3n.h'
	   elseif(nen.eq.4) then
		include 'sh2d4n.h'
	   end if
	elseif(nsd==3) then
	   if(nen.eq.4) then
		include 'sh3d4n.h'
	   elseif(nen.eq.8) then
		include 'sh3d8n.h'
	   end if
	end if
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

     eft0 = abs(det)*wq(iq)   ! calculate weight at each quad point

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

     dr(:) = 0.0

     do inl=1,nen
	dr(1:nsd) = dr(1:nsd)+sh(1:nsd,inl)*d(inl)
     end do

     ph(0:nsd,1:nen) = sh(0:nsd,1:nen)*eft0

     do inl=1,nen
	node=ien(inl,ie)
	do isd=1,nsd
	   p_inter(node)=p_inter(node)+ph(isd,inl)*dr(isd)
	end do! residual
     end do

     end do ! end of quad loop

  end do ! end of ele loop

end subroutine blockgmres_Laplace


c Modified Ziya Zhang's C code for Greenness on May 2009
c Compute daily GRND based on monthly info
c/* Take the value on 16th day of each month and interpolate between */
c/* Time (year, month, and date) needs to be given */
C
c INPUT: yr -- year
c	  mon -- month
c	  day -- day
c	  npix -- number of hrap pixels for selected basins
c	  grn -- grided grn values (1-D array) (12 months)
c  OUTPUT: daily grnd
C
c#include "models.h"

      subroutine get_daily_grn(yr,mon,day,npix,grn,grnday)

      integer yr,mon,day
      integer d1, d2, d3
      integer days_tot
      integer ndays(12)/31,28,31,30,31,30,31,31,30,31,30,31/
      real grn(12),grnday(1)
      real grn_tmp, grn_prev, grn_this, grn_next, grn_diff

      if (mon .eq. 1) then
       d1 = ndays(mon)
       if(mod(yr,4) .eq. 0 .and. mon .eq. 2) d1=d1+1
      else
       d1 = ndays(mon-1)
       if(mod(yr,4) .eq. 0 .and. mon-1 .eq. 2) d1=d1+1
      endif
      d2 = ndays(mon)
      if(mod(yr,4) .eq. 0 .and. mon .eq. 2) d2=d2+1

c /* determine value for days in the first half month */
c /* take this month's value as the value of 16th day of this month
c    and take the 16th day of the previous month and interpolate
c    between to get daily values */

      if (day .lt. 16) then
       do i=1,npix
	if (mon .eq. 1) then
	 grn_prev = grn(i+11*npix)
        else
	 grn_prev = grn(i+(mon-2)*npix)
	endif
        grn_this = grn(i+(mon-1)*npix)
	grn_diff = grn_this - grn_prev
	days_tot = d1
        grn_tmp = grn_this - (16-day)*grn_diff / days_tot
	grnday(i) = grn_tmp;
       enddo
c/* end of if (day < 16) */

c /* determine value for days in the second half month */
      else
c            /* if (day >= 16) {  */
       do i=1,npix
	grn_this = grn(i+(mon-1)*npix)
	if(mon .eq. 12) then
	 grn_next = grn(i)
	else
	 grn_next = grn(i+mon*npix)
	endif
	grn_diff = grn_this - grn_next
	days_tot = d2;
        grn_tmp = grn_this - (day-16)*grn_diff / days_tot
	grnday(i) = grn_tmp
       enddo
      endif
c   /* end of else ---if (day >= 16) */

      return
      end


SUBROUTINE CGERFS_F95(A, AF, IPIV, B, X, TRANS, FERR, BERR, INFO)
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS ..
   USE LA_PRECISION, ONLY: WP => SP
   USE LA_AUXMOD, ONLY: ERINFO, LSAME
   USE F77_LAPACK, ONLY: GERFS_F77 => LA_GERFS
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. SCALAR ARGUMENTS ..
   CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS
   INTEGER, INTENT(OUT), OPTIONAL :: INFO
!  .. ARRAY ARGUMENTS ..
   INTEGER, INTENT(IN), TARGET :: IPIV(:)
   COMPLEX(WP), INTENT(IN) :: A(:,:), AF(:,:), B(:,:)
   COMPLEX(WP), INTENT(INOUT) :: X(:,:)
   REAL(WP), INTENT(OUT), OPTIONAL, TARGET :: FERR(:), BERR(:)
!-----------------------------------------------------------------
!
! Purpose
! =======
!
! LA_GERFS improves the computed solution X of a system of linear
! equations   A X = B  or  A^T X = B
! and provides error bounds and backward error estimates for
! the solution. LA_GERFS uses the LU factors computed by LA_GETRF.
!
! Arguments
! =========
! SUBROUTINE LA_GERFS (A, AF, IPIV, B, X, TRANS, FERR, BERR, INFO)
!    <type>(<wp>), INTENT(IN)  :: A(:,:), AF(:,:), <rhs>
!    INTEGER, INTENT(IN) :: IPIV(:)
!    <type>(<wp>), INTENT(INOUT) :: <sol>
!    REAL(<wp>), INTENT(OUT), OPTIONAL :: <err>
!    CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS
!    INTEGER, INTENT(OUT), OPTIONAL :: INFO
!    where
!    <type> ::= REAL | COMPLEX
!    <wp>   ::= KIND(1.0) | KIND(1.0D0)
!    <rhs>  ::= B(:,:) | B(:)
!    <sol>  ::= X(:,:) | X(:)
!    <err>  ::= FERR(:), BERR(:) | FERR, BERR
!
! =====================
!
! A     (input) either REAL or COMPLEX square array,
!       shape (:,:), size(A,1) == size(A,2).
!       The original matrix A.
!
! AF    (input) either REAL or COMPLEX square array,
!       shape (:,:), size(AF,1) == size(AF,2) == size(A,1).
!       The factors L and U from the factorization A = PLU
!       as computed by LA_GETRF.
!
! IPIV  (input) INTEGER array, shape (:), size(IPIV) == size(A,1).
!       The pivot indices from LA_GETRF; for 1<=i<=size(A,1), row i
!       of the matrix was interchanged with row IPIV(i).
!
! B     (input) either REAL or COMPLEX rectangular array,
!       shape either (:,:) or (:), size(B,1) or size(B) == size(A,1).
!       The right hand side vector(s) of matrix B for
!       the system of equations AX = B.
!
! X     (input/output) either REAL or COMPLEX rectangular array,
!       shape either (:,:) or (:), size(X,1) or size(X) == size(A,1).
!       On entry, the solution matrix X, as computed by LA_GETRS.
!       On exit, the improved solution matrix X.
!
! TRANS Optional (input) CHARACTER*1
!       If TRANS is present, it specifies the form of the system
!       of equations:
!          = 'N':  A X = B    (No transpose)
!          = 'T':  A^T X = B  (Transpose)
!          = 'C':  A^H X = B  (Conjugate transpose = Transpose)
!       otherwise TRANS = 'N' is assumed.
!
! FERR  Optional (output) either REAL array of shape (:) or REAL
!       scalar. If it is an array, size(FERR) == size(X,2).
!       The estimated forward error bound for each solution vector
!       X(j) (the j-th column of the solution matrix X).
!       If XTRUE is the true solution corresponding to X(j), FERR(j)
!       is an estimated upper bound for the magnitude of the largest
!       element in (X(j) - XTRUE) divided by the magnitude of the
!       largest element in X(j).  The estimate is as reliable as
!       the estimate for RCOND, and is almost always a slight
!       overestimate of the true error.
!
! BERR  Optional (output) either REAL array of shape (:) or REAL
!       scalar. If it is an array, size(BERR) == size(X,2).
!       The componentwise relative backward error of each solution
!       vector X(j) (i.e., the smallest relative change in
!       any element of A or B that makes X(j) an exact solution).
!
! INFO  Optional (output) INTEGER.
!       If INFO is present
!          = 0: successful exit
!          < 0: if INFO = -k, the k-th argument had an illegal value
!       If INFO is not present and an error occurs, then the program is
!          terminated with an error message.
!
! Internal Parameters
! ===================
!
! ITMAX is the maximum number of steps of iterative refinement.
! It is set to 5 in the LAPACK77 subroutines
! -----------------------------------
!  .. PARAMETERS ..
   CHARACTER(LEN=8), PARAMETER :: SRNAME = 'LA_GERFS'
!  .. LOCAL SCALARS ..
   CHARACTER(LEN=1) :: LTRANS
   INTEGER :: LINFO, NRHS, N, ISTAT, ISTAT1, SFERR, SBERR
!  .. LOCAL ARRAYS, POINTERS ..
   REAL(WP), POINTER :: RWORK(:)
   REAL(WP), POINTER :: LFERR(:), LBERR(:)
   COMPLEX(WP), POINTER :: WORK(:)
!  .. INTRINSIC FUNCTIONS ..
   INTRINSIC PRESENT, SIZE, MAX
!  .. EXECUTABLE STATEMENTS ..
   LINFO = 0; ISTAT = 0; N = SIZE(A, 1); NRHS = SIZE(B, 2)
   IF( PRESENT(FERR) )THEN; SFERR = SIZE(FERR); ELSE; SFERR = NRHS; END IF
   IF( PRESENT(BERR) )THEN; SBERR = SIZE(BERR); ELSE; SBERR = NRHS; END IF
   IF(PRESENT(TRANS))THEN; LTRANS = TRANS; ELSE; LTRANS='N'
   END IF
!  .. TEST THE ARGUMENTS
   IF( SIZE(A, 2) /= N .OR. N < 0 )THEN; LINFO = -1
   ELSE IF( SIZE(AF, 1) /= N .OR. SIZE(AF, 2) /= N )THEN; LINFO = -2
   ELSE IF ( SIZE( IPIV ) /= N ) THEN; LINFO = -3
   ELSE IF ( SIZE(B, 1) /= N ) THEN; LINFO = -4
   ELSE IF ( SIZE(X, 1) /= N .OR. SIZE(X, 2) /= NRHS ) THEN; LINFO = -5
   ELSE IF( .NOT.( LSAME(LTRANS,'N') .OR.  LSAME(LTRANS,'T') .OR. &
                  LSAME(LTRANS,'C') ) )THEN; LINFO = -6
   ELSE IF( SFERR /= NRHS )THEN; LINFO = -7
   ELSE IF( SBERR /= NRHS )THEN; LINFO = -8
   ELSE IF ( N > 0 ) THEN
      IF( .NOT.PRESENT(FERR) ) THEN
         ALLOCATE( LFERR(NRHS), STAT=ISTAT )
      ELSE; LFERR => FERR; END IF
      IF( ISTAT == 0 )THEN
         IF( .NOT.PRESENT(BERR) ) THEN
            ALLOCATE( LBERR(NRHS), STAT=ISTAT )
         ELSE; LBERR => BERR; END IF
      END IF
      IF( ISTAT == 0 )THEN; ALLOCATE( WORK(2*N), RWORK(N), STAT=ISTAT ); END IF
      IF( ISTAT == 0 )THEN
!        .. CALL LAPACK77 ROUTINE
         CALL GERFS_F77( LTRANS, N, NRHS, A, MAX(1,N), AF, MAX(1,N), &
                         IPIV, B, MAX(1,N), X, MAX(1,N), LFERR, &
                         LBERR, WORK, RWORK, LINFO )
      ELSE; LINFO = -100; END IF
      IF( .NOT.PRESENT(FERR) ) DEALLOCATE( LFERR, STAT=ISTAT1 )
      IF( .NOT.PRESENT(BERR) ) DEALLOCATE( LBERR, STAT=ISTAT1 )
      DEALLOCATE(WORK, RWORK, STAT=ISTAT1 )
   END IF
   CALL ERINFO( LINFO, SRNAME, INFO, ISTAT )
END SUBROUTINE CGERFS_F95


C 	Copyright restrictions apply - see stsdas$copyright.stsdas
C
        SUBROUTINE TABINV(X,N,XVAL,RPOS)
*
*  Module number: HRS/FOS UTILITY
*
*  Module name: TABINV
*
*  Keyphrase:
*  ----------
*       find table position
*  Description:
*  ------------
*       this routine finds the position of XVAL in the vector
*       X.  If XVAL is not in the array X then linear interpolation
*       or extrapolation is used to give a relative postion.
*       The input vector x must be in ascending order.
*
*  FORTRAN name: tabinv.for
*
*  Keywords of accessed files and tables:
*  --------------------------------------
*       none
*
*  Subroutines Called:
*  -------------------
*       none
*
*  History:
*  --------
*  Version      Date        Author          Description
*    1         Oct. 87    D. Lindler    Designed and coded
*-------------------------------------------------------------------------------
C
C INPUT PARAMETERS
C
C       X - VECTOR OF VALUES TO SEARCH (REAL*8)
C       N - NUMBER OF ELEMENTS IN X (INTEGER)
C       XVAL - VALUE TO SEARCH FOR (REAL*8)
C
C OUTPUT PARAMETERS
C
C       RPOS - EFFECTIVE INDEX POSITION (REAL*8)
C
C----------------------------------------------------------------------------
	IMPLICIT NONE
        INTEGER N
        DOUBLE PRECISION X(N),XVAL,RPOS
C
C LOCAL VARIABLES
C
        INTEGER I,I1,IPOS
        DOUBLE PRECISION DIF
C
C LOOP TO FIND WHICH TWO VALUES X LIES BETWEEN
C
        DO 10 I=2,N
                IPOS=I
                IF(XVAL .LT. X(I)) GO TO 20
10      CONTINUE
C
C INTERPOLATE TO FIND EFFECTIVE INDEX
C
20      I1=IPOS-1
        DIF = X(IPOS)-X(I1)
        IF(DIF.EQ.0)THEN
                RPOS = I1+0.5
           ELSE
                RPOS = I1 + (XVAL-X(I1))/DIF
        ENDIF
        RETURN
        END


      subroutine dt2d(d1,d2,t2,edt2d)

      implicit double precision(a-h,o-z)

      dimension d1(3),d2(3),t2(3,3)

c  this subroutine evaluates the quadrupole-quadrupole
c  electrostatic interaction

      dimension a(6),b(6)

      a(1)=t2(1,1)
      a(2)=t2(1,2)
      a(3)=t2(1,3)
      a(4)=t2(2,2)
      a(5)=t2(2,3)
      a(6)=t2(3,3)

      b(1)=d1(1)*d2(1)
      b(2)=d1(1)*d2(2)+d1(2)*d2(1)
      b(3)=d1(1)*d2(3)+d1(3)*d2(1)
      b(4)=d1(2)*d2(2)
      b(5)=d1(2)*d2(3)+d1(3)*d2(2)
      b(6)=d1(3)*d2(3)

      edt2d=a(1)*b(1)+a(2)*b(2)+a(3)*b(3)+a(4)*b(4)+
     .      a(5)*b(5)+a(6)*b(6)

      return
      end


SUBROUTINE buryadj(burycoef,mnrbc,speed,stdspeed,minspeed,maxspeed,depth,       &
                 & stddepth,mindepth,maxdepth)
!
IMPLICIT NONE
!
! PARAMETER definitions
!
REAL,PARAMETER :: expspeed = 0.5,s1speed = 0.6,s2speed = 0.4,expdepth = 2.7
!
! Subroutine arguments
!
REAL :: depth,maxdepth,maxspeed,mindepth,minspeed,speed,stddepth,stdspeed
INTEGER :: mnrbc
REAL,DIMENSION(mnrbc) :: burycoef
!
! Local variables
!
INTEGER :: index
REAL :: rdepth,rspeed
!
!     argument declarations

!     argument definitions
!     burycoef - burial fraction coefficient to be adjusted
!     mnrbc    - number of burial coefficients (residue burial classes)
!     speed    - actual
!     stdspeed - standard, where coefficient remains unchanged
!     minspeed - minimum
!     maxspeed - maximum
!     depth    - actual
!     stddepth - standard, where coefficient remains unchanged
!     mindepth - minimum
!     maxdepth - maximum

!     local variable declarations

!     find speed adjustment parameter
speed = max(min(speed,maxspeed),minspeed)
rspeed = (s1speed+s2speed*(speed/maxspeed)**expspeed)                           &
       & /(s1speed+s2speed*(stdspeed/maxspeed)**expspeed)

!     find depth adjustment parameter
depth = max(min(depth,maxdepth),mindepth)
rdepth = (1.0-(1.0-depth/maxdepth)**expdepth)                                   &
       & /(1.0-(1.0-stddepth/maxdepth)**expdepth)

!     adjust burial coefficients and keep within range 0 to 1
DO index = 1,mnrbc
  burycoef(index) = burycoef(index)*rspeed*rdepth
  burycoef(index) = min(1.0,max(0.0,burycoef(index)))
END DO
!
END SUBROUTINE buryadj

Project Documents/Source Code Original/Buryadj.f90


************************************************************************
      function next235(base)
      implicit none
      integer :: next235, numdiv
      double precision :: base
c ----------------------------------------------------------------------
c     integer function next235 returns a multiple of 2, 3, and 5
c
c     next235 = 2^p 3^q 5^r >= base  where p>=1, q>=0, r>=0
************************************************************************
      next235 = 2 * int(base/2d0+.9999d0)
      if (next235.le.0) next235 = 2

100   numdiv = next235
      do while (numdiv/2*2 .eq. numdiv)
         numdiv = numdiv /2
      enddo
      do while (numdiv/3*3 .eq. numdiv)
         numdiv = numdiv /3
      enddo
      do while (numdiv/5*5 .eq. numdiv)
         numdiv = numdiv /5
      enddo
      if (numdiv .eq. 1) return
      next235 = next235 + 2
      goto 100
      end


!-----------------------------------------------------------------------
!
! Header with common subroutine
!
      include 't320-basis-f.h'
!-----------------------------------------------------------------------
      subroutine feval(x1,x2,val)
      real*8 x1,x2,val

      val=x1*x1+x2*x2+x1*x2+1

      end
!-----------------------------------------------------------------------
      program test
      implicit none
      include 'ceedf.h'

      integer ceed,err
      integer input,output,weights
      integer p,q,d
      parameter(p=6)
      parameter(q=4)
      parameter(d=2)

      real*8 qref(d*q)
      real*8 qweight(q)
      real*8 interp(p*q)
      real*8 grad(d*p*q)
      real*8 xr(d*p)
      real*8 iinput(p)
      real*8 ooutput(q)
      real*8 wweights(q)
      real*8 val,diff
      real*8 x1,x2
      integer*8 ioffset,offset1,offset2

      integer b,i

      character arg*32

      xr=(/0.0d0,5.0d-1,1.0d0,0.0d0,5.0d-1,0.0d0,0.0d0,0.0d0,0.0d0,5.0d-1,&
     &  5.0d-1,1.0d0/)

      call getarg(1,arg)

      call buildmats(qref,qweight,interp,grad)

      call ceedinit(trim(arg)//char(0),ceed,err)

      call ceedbasiscreateh1(ceed,ceed_triangle,1,p,q,interp,grad,qref,qweight,&
     & b,err)

      do i=1,p
        x1=xr(0*p+i)
        x2=xr(1*p+i)
        call feval(x1,x2,val)
        iinput(i)=val
      enddo

      call ceedvectorcreate(ceed,p,input,err)
      ioffset=0
      call ceedvectorsetarray(input,ceed_mem_host,ceed_use_pointer,iinput,&
     & ioffset,err)
      call ceedvectorcreate(ceed,q,output,err)
      call ceedvectorsetvalue(output,0.d0,err)
      call ceedvectorcreate(ceed,q,weights,err)
      call ceedvectorsetvalue(weights,0.d0,err)

      call ceedbasisapply(b,1,ceed_notranspose,ceed_eval_interp,input,output,&
     & err)
      call ceedbasisapply(b,1,ceed_notranspose,ceed_eval_weight,&
     & ceed_vector_none,weights,err)

      call ceedvectorgetarrayread(output,ceed_mem_host,ooutput,offset1,err)
      call ceedvectorgetarrayread(weights,ceed_mem_host,wweights,offset2,err)
      val=0
      do i=1,q
        val=val+ooutput(i+offset1)*wweights(i+offset2)
      enddo
      call ceedvectorrestorearrayread(output,ooutput,offset1,err)
      call ceedvectorrestorearrayread(weights,wweights,offset2,err)

      diff=val-17.d0/24.d0
      if (abs(diff)>1.0d-10) then
! LCOV_EXCL_START
        write(*,'(A,I1,A,F12.8,A,F12.8)')'[',i,'] ',val,' != ',17.d0/24.d0
! LCOV_EXCL_STOP
      endif

      call ceedvectordestroy(input,err)
      call ceedvectordestroy(output,err)
      call ceedvectordestroy(weights,err)
      call ceedbasisdestroy(b,err)
      call ceeddestroy(ceed,err)

      end
!-----------------------------------------------------------------------


      subroutine init_iphi(ctfmp,x,Nx,myzero,res)
      implicit none
      integer i
      integer Nx
      real*8 myzero
      real*8 ctfmp(Nx)
      real*8 x(Nx)
      real*8 res(Nx)
      real*8 qb
      do i=1, Nx, 1
      qb = 0.2D1 * myzero * x(i) / ctfmp(i)
      res(i)=qb
      end do
      END


!==============================================================================!
  subroutine CalcVort(grid)
!------------------------------------------------------------------------------!
!  Computes the magnitude of the vorticity                                     !
!------------------------------------------------------------------------------!
!  Vort = sqrt( 2 * Sij * Sij )                                                !
!  Sij = 1/2 ( dUi/dXj - dUj/dXi )                                             !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use all_mod
  use pro_mod
  use les_mod
  use rans_mod
  use Grid_Mod
  use Work_Mod, only: u_x => r_cell_01,  &
                      u_y => r_cell_02,  &
                      u_z => r_cell_03,  &
                      v_x => r_cell_04,  &
                      v_y => r_cell_05,  &
                      v_z => r_cell_06,  &
                      w_x => r_cell_07,  &
                      w_y => r_cell_08,  &
                      w_z => r_cell_09
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Grid_Type) :: grid
!-----------------------------------[Locals]-----------------------------------!
  integer :: c
!==============================================================================!

  call Exchange(grid, u % n)
  call Exchange(grid, v % n)
  call Exchange(grid, w % n)

  call GraPhi(grid, u % n, 1, u_x, .TRUE.)  ! du/dx
  call GraPhi(grid, u % n, 2, u_y, .TRUE.)  ! du/dy
  call GraPhi(grid, u % n, 3, u_z, .TRUE.)  ! du/dz

  call GraPhi(grid, v % n, 1, v_x, .TRUE.)  ! dv/dx
  call GraPhi(grid, v % n, 2, v_y, .TRUE.)  ! dv/dy
  call GraPhi(grid, v % n, 3, v_z, .TRUE.)  ! dv/dz

  call GraPhi(grid, w % n, 1, w_x, .TRUE.)  ! dw/dx
  call GraPhi(grid, w % n, 2, w_y, .TRUE.)  ! dw/dy
  call GraPhi(grid, w % n, 3, w_z, .TRUE.)  ! dw/dz

  do c = 1, grid % n_cells
    vort(c) = 2.0 * (0.5 * (w_y(c) - v_z(c)))**2  &
            + 2.0 * (0.5 * (w_x(c) - u_z(c)))**2  &
            + 2.0 * (0.5 * (v_x(c) - u_y(c)))**2

    vort(c) = sqrt(abs(2.0 * vort(c)))
  end do

  end subroutine


      subroutine strang(prosca,n,m,depl,jmin,jmax,precon,alpha,ybar,
     /                 sbar,izs,rzs,dzs)
c----
c
c     Calcule le produit H g ou
c         . H est une matrice construite par la formule de bfgs inverse
c           a m memoires a partir de precon fois la matrice unite dans
c           un espace hilbertien dont le produit scalaire est donne par
c           prosca
c           (cf. J. Nocedal, math. of comp. 35/151 (1980) 773-782)
c         . g est un vecteur de dimension n (en general le gradient)
c
c     Le facteur precon apparait donc comme un preconditionneur
c     scalaire.
c
c     delp = g (en entree), = H g (en sortie)
c
c     La matrice H est memorisee par les vecteurs des tableaux
c     ybar, sbar et les pointeurs jmin, jmax.
c
c     alpha(m) est une zone de travail.
c
c     izs(1),rzs(1),dzs(1) sont des zones de travail pour prosca
c
c----
c
c         arguments
c
      integer n,m,jmin,jmax,izs(*)
      real rzs(*)
      double precision depl(n),precon,alpha(m),ybar(n,m),sbar(n,m)
      double precision dzs(*)
      external prosca
c
c         variables locales
c
      integer jfin,i,j,jp
      double precision r
      double precision ps
c
      jfin=jmax
      if (jfin.lt.jmin) jfin=jmax+m
c
c         phase de descente
c
      do 100 j=jfin,jmin,-1
          jp=j
          if (jp.gt.m) jp=jp-m
          call prosca (n,depl,sbar(1,jp),ps,izs,rzs,dzs)
          alpha(jp)=ps
          do 20 i=1,n
              depl(i)=depl(i)-ps*ybar(i,jp)
20        continue
100   continue
c
c         preconditionnement
c
      do 150 i=1,n
          depl(i)=depl(i)*precon
150   continue
c
c         remontee
c
      do 200 j=jmin,jfin
          jp=j
          if (jp.gt.m) jp=jp-m
          call prosca (n,depl,ybar(1,jp),ps,izs,rzs,dzs)
          r=alpha(jp)-ps
          do 120 i=1,n
              depl(i)=depl(i)+r*sbar(i,jp)
120       continue
200   continue
      return
      end


subroutine foo(M)
        double complex :: M
        if (M .ne. (100,100)) then
                write(*,*) "Failed"
                stop 2
        endif
        end subroutine foo

program test
         integer :: i,j
         double complex :: M,N
         double complex,pointer :: A(:)

        allocate(A(10))
        M=(0,0)

        do i=1, 10
          A(i)=(1,1)
        enddo

!$omp target teams distribute map(to:A) map(tofrom:M) reduction(+:M)
       do i=1, 10
!$omp parallel do reduction(+:M)
         do j=1, 10
           M=M+A(j)
         enddo
!$omp end parallel do
      enddo
!$omp end target teams distribute

       write(*, *) "M=", M
       call foo(M)
end program test


      PROGRAM xspctrm
C     driver for routine spctrm
      INTEGER M,M4
      PARAMETER(M=16,M4=4*M)
      INTEGER j,k
      REAL p(M),q(M),w1(M4),w2(M)
      LOGICAL ovrlap
      open(9,file='SPCTRL.DAT',status='OLD')
      k=8
      ovrlap=.true.
      call spctrm(p,M,k,ovrlap,w1,w2)
      rewind(9)
      k=16
      ovrlap=.false.
      call spctrm(q,M,k,ovrlap,w1,w2)
      close(9)
      write(*,*) 'Spectrum of DATA in file SPCTRL.DAT'
      write(*,'(1x,t14,a,t29,a)') 'Overlapped','Non-Overlapped'
      do 11 j=1,M
        write(*,'(1x,i4,2f17.6)') j,p(j),q(j)
11    continue
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xspctrm.for


!##############################################################################
! PROGRAM LR_OLG
!
! ## Long-run equilibria in the overlapping generations model
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
include "prog06_01m.f90"

program LR_OLG

    use globals
    use toolbox

    implicit none
    logical :: check
    integer :: j
    real*8 :: x(2)

    ! initialize labor supply, pension payments and tax rates
    LL = (2d0+n_p)/(1d0+n_p)
    taup = kappa/((2d0+n_p)*(1d0+n_p))
    tauc = 0d0
    tauw = 0d0
    taur = 0d0

    ! get initial guess
    x(:) = 0.7d0

    ! solve the steady state equation system
    call fzero(x, eqns, check)

    ! check whether the solution is valid
    if(check)stop 'No equilibirium found !'

    ! calculate household utility
    util = 0d0
    do j = 1, 3
        util = util + beta**(j-1)*c(j)**egam/egam
    enddo

    ! Output
    write(*,'(a/)')'  Steady state equilibrium'
    write(*,'(a)')'     c1     c2     c3      Y      w      r      U '
    write(*,'(7f7.2/)')c(:), YY, w, r, util

    write(*,'(a)')'     a2     a3      K '
    write(*,'(3f7.2/)')a(2), a(3), KK

    write(*,'(a)')'   tauw   taur   tauc   taup    pen      B'
    write(*,'(6f7.2/)')tauw, taur, tauc, taup, pen, BB

    write(*,'(a)')'      Y      C      G      I      DIFF'
    write(*,'(4f7.2,1f10.4)')YY,CC,GG,II,YY-CC-GG-II

end program


! { dg-do run { xfail hppa*-*-hpux* } }
! { dg-require-effective-target fortran_largest_fp_has_sqrt }
!
! This test checks whether the largest possible
! floating-point number works.
!
! This is a run-time check. Depending on the architecture,
! this tests REAL(8), REAL(10) or REAL(16) and REAL(16)
! might be a hardware or libquadmath 128bit number.
!
program test_qp
   use iso_fortran_env, only: real_kinds
   implicit none
   integer, parameter :: QP = real_kinds(ubound(real_kinds,dim=1))
   real(qp) :: fp1, fp2, fp3, fp4
   character(len=80) :: str1, str2, str3, str4
   fp1 = 1
   fp2 = sqrt (2.0_qp)
   write (str1,*) fp1
   write (str2,'(g0)') fp1
   write (str3,*) fp2
   write (str4,'(g0)') fp2

!   print '(3a)', '>',trim(str1),'<'
!   print '(3a)', '>',trim(str2),'<'
!   print '(3a)', '>',trim(str3),'<'
!   print '(3a)', '>',trim(str4),'<'

   read (str1, *) fp3
   if (fp1 /= fp3) STOP 1
   read (str2, *) fp3
   if (fp1 /= fp3) STOP 2
   read (str3, *) fp4
   if (abs (fp2 - fp4)/fp2 > epsilon(fp2)) STOP 3
   read (str4, *) fp4
   if (abs (fp2 - fp4)/fp2 > epsilon(fp2)) STOP 4

   select case (qp)
     case (8)
       if (str1 /= "   1.0000000000000000") STOP 5
       if (str2 /= "1.0000000000000000") STOP 6
       if (str3 /= "   1.4142135623730951") STOP 7
       if (str4 /= "1.4142135623730951") STOP 8

     case (10)
       if (str1 /= "   1.00000000000000000000") STOP 9
       if (str2 /= "1.00000000000000000000") STOP 10
       if (str3 /= "   1.41421356237309504876") STOP 11
       if (str4 /= "1.41421356237309504876") STOP 12

     case (16)
       if (digits(1.0_qp) == 113) then
         ! IEEE 754 binary 128 format
         ! e.g. libquadmath/__float128 on i686/x86_64/ia64
         if (str1 /= "   1.00000000000000000000000000000000000") STOP 13
         if (str2 /= "1.00000000000000000000000000000000000") STOP 14
         if (str3 /= "   1.41421356237309504880168872420969798") STOP 15
         if (str4 /= "1.41421356237309504880168872420969798") STOP 16
       else if (digits(1.0_qp) == 106) then
         ! IBM binary 128 format
         if (str1 /= "   1.0000000000000000000000000000000") STOP 17
         if (str2 /= "1.0000000000000000000000000000000") STOP 18
         if (str3(1:37) /= "   1.4142135623730950488016887242097") STOP 19
         if (str4(1:34) /= "1.4142135623730950488016887242097") STOP 20
       end if

       ! Do a libm run-time test
       block
         real(qp), volatile :: fp2a
         fp2a = 2.0_qp
         fp2a = sqrt (fp2a)
         if (abs (fp2a - fp2) > sqrt(2.0_qp)-nearest(sqrt(2.0_qp),-1.0_qp)) STOP 21
       end block

     case default
       STOP 22
   end select

end program test_qp