module lapack_wrapper

  use numeric_kinds, only: dp
  implicit none

  !> \private
  private
  !> \public
  public :: lapack_generalized_eigensolver, lapack_generalized_eigensolver_lowest, &
       lapack_matmul, lapack_matrix_vector, lapack_qr, lapack_solver, lapack_sort

contains

    subroutine lapack_generalized_eigensolver(mtx, eigenvalues, eigenvectors, stx)
    !> Call the DSYGV subroutine lapack to compute ALL the eigenvalues
    !> and corresponding eigenvectors of mtx
    !> \param mtx: Matrix to diaogonalize
    !> \param stx: Overlap Matrix to diaogonalize
    !> \param eigenvalues: lowest eigenvalues
    !> \param eigenvectors: corresponding eigenvectors
    !> \return eigenvalues/eigenvectors

    ! input/output
    implicit none
    real(dp), dimension(:, :), intent(in) :: mtx
    real(dp), dimension(:, :), intent(in), optional :: stx
    real(dp), dimension(size(mtx, 1)), intent(inout) :: eigenvalues
    real(dp), dimension(size(mtx, 1), size(mtx, 2)), intent(inout) :: eigenvectors

    real(dp), dimension(:, :), allocatable :: mtx_copy
    real(dp), dimension(:, :), allocatable :: stx_copy

    ! Local variables
    integer :: dim, info, lwork, itype = 1
    logical :: gev

     ! ALL the eigenvalues of the subpace (re, im)
    real(dp), dimension(size(mtx, 1)) :: eigenvalues_work
    real(dp), dimension(:), allocatable :: work ! workspace, see lapack documentation

    ! ! dimension of the guess space
    dim = size(mtx, 1)
    gev = present(stx)

    ! local copy of the matrices
    allocate(mtx_copy(dim,dim))
    mtx_copy = mtx

    if (gev) then
      allocate(stx_copy(dim,dim))
      stx_copy = stx
    end if

    ! Query size of the optimal workspace
    allocate(work(1))

    if (gev) then
      call DSYGV(itype,"V", "U", dim, mtx_copy, dim, stx_copy, dim, eigenvalues_work, work, -1, info)
      call check_lapack_call(info, "DSYGV")
    else
      call DSYEV("V", "U", dim, mtx_copy, dim, eigenvalues_work, work, -1, info)
      call check_lapack_call(info, "DSYEV")
    end if

    ! Allocate memory for the workspace
    lwork = max(1, int(work(1)))
    deallocate(work)
    allocate(work(lwork))

    ! Compute Eigenvalues
    if (gev) then
      call DSYGV(itype,"V", "U", dim, mtx_copy, dim, stx_copy, dim, eigenvalues_work, work, lwork, info)
      call check_lapack_call(info, "DSYGV")
    else
      call DSYEV("V", "U", dim, mtx_copy, dim, eigenvalues_work, work, lwork, info)
      call check_lapack_call(info, "DSYEV")
    end if

    ! Sort the eigenvalues and eigenvectors of the basis
    eigenvalues = eigenvalues_work
    eigenvectors = mtx_copy

    ! release memory
    deallocate(work)
    deallocate(mtx_copy)
    if (gev) then
      deallocate(stx_copy)
    end if

  end subroutine lapack_generalized_eigensolver

  subroutine lapack_generalized_eigensolver_lowest(mtx, stx, eigenvalues, eigenvectors, lowest)
    !> Call the DSYGVX subroutine lapack to compute the lowest eigenvalues
    !> and corresponding eigenvectors of mtx
    !> \param mtx: Matrix to diaogonalize
    !> \param stx: Overlap Matrix to diaogonalize
    !> \param eigenvalues: lowest eigenvalues
    !> \param eigenvectors: corresponding eigenvectors
    !> \param lowest: number of lowest eigenvalues/eigenvectors pairs to compute
    !> \return eigenvalues/eigenvectors

    ! input/output
    implicit none
    integer :: lowest
    real(dp), dimension(:, :), intent(in) :: mtx
    real(dp), dimension(:, :), intent(in) :: stx
    real(dp), dimension(lowest), intent(out) :: eigenvalues
    real(dp), dimension(size(mtx, 1), lowest), intent(out) :: eigenvectors

    ! Local variables
    real(dp), dimension(:, :), allocatable :: mtx_copy
    real(dp), dimension(:, :), allocatable :: stx_copy

    integer :: dim, info,  lwork, m, itype = 1
    real(dp) :: vl, vu, abstol

    ! Failed eigenvalues
    integer, dimension(size(mtx, 1)) :: ifail

     ! ALL the eigenvalues of the subpace (re, im)
    real(dp), dimension(size(mtx, 1)) :: eigenvalues_work
    real(dp), dimension(size(mtx, 1), lowest) :: eigenvectors_work
    real(dp), dimension(:), allocatable :: work ! workspace, see lapack documentation
    integer, dimension(:), allocatable :: iwork ! workspace, see lapack documentation

    ! ! dimension of the guess space
    dim = size(mtx, 1)

    ! local copy of the matrices
    allocate(mtx_copy(dim,dim))
    mtx_copy = mtx

    allocate(stx_copy(dim,dim))
    stx_copy = stx

    ! LAPACK SAYS: If range = 'A' or 'I', vl and vu are not referenced
    vl = 0.0_dp
    vu = 0.0_dp

    ! Absolute tolerance

    ! Query size of the optimal workspace
    allocate(work(1))
    allocate(iwork(1))

    call DSYGVX(itype,"V", "I", "U", dim, mtx_copy, dim, stx_copy, dim, vl, vu, &
         1, lowest, abstol, m, eigenvalues_work, eigenvectors_work, &
         dim, work, -1, iwork, ifail, info)
    call check_lapack_call(info, "DSYGVX")

    ! Allocate memory for the workspace
    lwork = max(1, int(work(1)))
    deallocate(work, iwork)
    allocate(work(lwork))
    allocate(iwork(lwork))

    ! Compute Eigenvalues

    call DSYGVX(itype,"V", "I", "U", dim, mtx_copy, dim, stx_copy, dim, vl, vu, &
         1, lowest, abstol, m, eigenvalues_work, eigenvectors_work, &
         dim, work, lwork, iwork, ifail, info)

    call check_lapack_call(info, "DSYGVX")

    ! Copy the eigenvalues and eigenvectors
    eigenvalues = eigenvalues_work(1:lowest)
    eigenvectors = eigenvectors_work(1:dim, 1:lowest)

    ! release memory
    deallocate(work, iwork, mtx_copy, stx_copy)

  end subroutine lapack_generalized_eigensolver_lowest

  subroutine lapack_qr(basis)
    !> Orthoghonalize the basis using the QR factorization.
    !> QR factorization of the M-by-N (M>N) matrx A=Q*R in the form where
    !> Q is square M-by-M matrix and R is an upper triangular M-by-N matrix.
    !> The equality A=Q*R can be re-written also as a product Q1*R1 where Q1
    !> is a rectangular M-by-N submatrix of the matrix Q and R1 is M-by-M
    !> submatrix of the R. Let us note that columns of Q1 are orthonormal
    !> (they are orthogonal to each other and have norms equal to 1).
    !> The equality A=Q1*R1 can be treated as every column of A is a linear
    !> combination of Q1 columns, i.e. they span the same linear space.
    !> In other words, columns of Q1 is the result of ortogonalization of columns A.
    !> DGEQRF does not not compute Q directly, DORGQR must be call subsequently.

    !> \param basis
    !> \return orthogonal basis

    implicit none
    real(dp), dimension(:, :), intent(inout) :: basis
    real(dp), dimension(:), allocatable :: work ! workspace, see lapack documentation
    real(dp), dimension(size(basis, 2)) :: tau ! see DGEQRF documentation
    integer :: info, lwork, m, n

    ! Matrix shape
    m = size(basis, 1)
    n = size(basis, 2)

    ! 1. Call the QR decomposition
    ! 1.1 Query size of the workspace (Check lapack documentation)
    allocate(work(1))
    call DGEQRF(m, n, basis, m, tau, work, -1, info)
    call check_lapack_call(info, "DGEQRF")

    ! 1.2 Allocate memory for the workspace
    lwork = max(1, int(work(1)))
    deallocate(work)
    allocate(work(lwork))

    ! 1.3 Call QR factorization
    call DGEQRF(m, n, basis, m, tau, work, lwork, info)
    call check_lapack_call(info, "DGEQRF")
    deallocate(work)

    ! 2. Generates an orthonormal matrix
    ! 2.1 Query size of the workspace (Check lapack documentation)
    allocate(work(1))
    call DORGQR(m, n, min(m, n), basis, m, tau, work, -1, info)
    call check_lapack_call(info, "DORGQR")

    ! 2.2 Allocate memory fo the workspace
    lwork = max(1, int(work(1)))
    deallocate(work)
    allocate(work(lwork))

    ! 2.3 compute the matrix Q
    call DORGQR(m, n, min(m, n), basis, m, tau, work, lwork, info)
    call check_lapack_call(info, "DORGQR")

    ! release memory
    deallocate(work)

  end subroutine lapack_qr

  subroutine lapack_solver(arr, brr)
    !> Call lapack DSYSV subroutine to solve a AX=B Linear system
    !> \param arr: matrix with the coefficients of the linear system
    !> \param brr: Vector with the constant terms
    !> \returns: Solution vector X (overwriten brr)

    implicit none

    real(dp), dimension(:, :), intent(inout) :: arr, brr

    ! local variables
    real(dp), dimension(:), allocatable :: work
    integer :: n, info, lwork
    integer, dimension(size(arr, 1)) :: ipiv

    n = size(arr, 1)

    ! query spacework size
    allocate(work(1))
    call DSYSV("U", n, 1, arr, n, ipiv, brr, n, work, -1, info)
    call check_lapack_call(info, "DSYSV")

    ! Allocate memory fo the workspace
    lwork = max(1, int(work(1)))
    deallocate(work)
    allocate(work(lwork))

    ! run linear solver
    call DSYSV("U", n, 1, arr, n, ipiv, brr, n, work, lwork, info)
    ! If the diagonalization fails due to a singular value try to recover
    ! by replacing the 0 value with a tiny one
    if (info > 0) then
       arr(info, info) = tiny(arr(1, 1))
       call DSYSV("U", n, 1, arr, n, ipiv, brr, n, work, lwork, info)
       call check_lapack_call(info, "DSYSV")
    end if

    deallocate(work)

  end subroutine lapack_solver

    function lapack_matmul(transA, transB, arr, brr, alpha) result (mtx)
    !> perform the matrix multiplication alpha * arr ^ (transA) * brr ^ (transB)
    !> see Lapack DGEMM for further details
    !> \param transA: 'T' transpose A, 'N' do not tranpose
    !> \param transB: 'T' transpose B, 'N' do not tranpose
    !> \param arr: first matrix to multiply
    !> \param brr: second matrix
    !> \param alpha: optional scalar number
    !> \return matrix multiplication

    implicit none

    character(len=1), intent(in) :: transA, transB
    real(dp), dimension(:, :), intent(in) :: arr, brr
    real(dp), optional, intent(in) :: alpha
    real(dp), dimension(:, :), allocatable :: mtx

    ! local variables
    real(dp) :: x
    integer :: m, n, k, lda, ldb
    x = 1.d0

    ! check optional variable
    if (present(alpha)) x=alpha

    if (transA == 'T') then
       k = size(arr, 1)
       m = size(arr, 2)
       lda = k
    else
       k = size(arr, 2)
       m = size(arr, 1)
       lda = m
    end if

    if (transB == 'T') then
       n = size(brr, 1)
       ldb = n
    else
       n = size(brr, 2)
       ldb = k
    end if

    ! resulting array
    allocate(mtx(m, n))
    mtx = 0.d0

    call DGEMM(transA, transB, m, n, k, x, arr, lda, brr, ldb, 0.d0, mtx, m)

  end function lapack_matmul

  function lapack_matrix_vector(transA, mtx, vector, alpha) result(rs)
    !> perform the Matrix vector multiplication alpha * mtx ^ (transA) * vector
    !> see DGEMV for details
    !> \param transA: 'T' transpose A; 'N' do not transpose
    !> \param mtx: matrix to multiply
    !> \param vector: vector to multiply
    !> \param alpha: optional scalar value
    !> \return resulting vector

    implicit none

    character(len=1), intent(in) :: transA
    real(dp), dimension(:, :), intent(in) :: mtx
    real(dp), dimension(:), intent(in) :: vector
    real(dp), optional, intent(in) :: alpha
    real(dp), dimension(:), allocatable :: rs

    ! local variable
    integer :: m, n
    real(dp) :: scalar
    scalar = 1.d0

    ! check optional variable
    if (present(alpha)) scalar=alpha

    ! number of row of mtx
    m = size(mtx, 1)
    n = size(mtx, 2)

    allocate(rs(m))
    rs = 0.d0

    call DGEMV(transA, m, n, scalar, mtx, m, vector, 1, 0.d0, rs, 1)

  end function lapack_matrix_vector

  function lapack_sort(id, vector) result(keys)
    !> \brief sort a vector of douboles
    !> \param vector Array to sort
    !> \param keys Indices of the sorted array
    !> \param id Sorted either `I` increasing or `D` decreasing
    real(dp), dimension(:), intent(inout) :: vector
    character(len=1), intent(in) :: id
    integer, dimension(size(vector)) :: keys

    ! local variables
    real(dp), dimension(size(vector)) :: xs
    integer :: i, j, info
    xs = vector

    call DLASRT(id, size(vector), vector, info)
    call check_lapack_call(info, "DLASRT")

    do i=1,size(vector)
       do j=1, size(vector)
          if (abs(vector(j) - xs(i)) < 1e-16) then
             keys(i) = j
          end if
       end do
    end do

  end function lapack_sort

  subroutine check_lapack_call(info, name)
    !> Check if a subroutine finishes sucessfully
    !> \param info: Termination signal
    !> \param name: Name of the subroutine
    integer :: info
    character(len=*), intent(in) :: name

    if (info /= 0) then
       print *, "call to subroutine: ", name, " has failed!"
       print *, "info: ", info
       error stop
    end if

  end subroutine check_lapack_call

end module lapack_wrapper


program demo_inum0
use M_calculator, only : inum0
implicit none
integer :: i,j,k
   i=inum0('20/3.4')
   j=inum0('CI = 13 * 3.1')
   k=inum0('CI')
   write(*,*)'Answers are ',I,J,K
end program demo_inum0


      subroutine n1qn3 (simul,prosca,ctonb,ctcab,n,x,f,g,dxmin,df1,
     /                  epsg,impres,io,mode,niter,nsim,dz,ndz,
     /                  izs,rzs,dzs)
c----
c
c
c     Utilise les sous-routines:
c         n1qn3a
c         ddd2
c         nlis0 + dcube (XII/88)
c
c     La sous-routine n1qn3 est une interface entre le programme
c     appelant et la sous-routine n1qn3a, le minimiseur proprement dit.
c
c     Le module prosca est sense realiser le produit scalaire de deux
c     vecteurs de Rn; le module ctonb est sense realiser le changement
c     bases: base euclidienne -> base orthonormale (pour le produit
c     scalaire prosca); le module ctbas fait la transformation inverse:
c     base orthonormale -> base euclidienne.
c
c     dz est la zone de travail pour n1qn3a, de dimension ndz.
c     Elle est subdivisee en
c         4 vecteurs de dimension n: d,gg,diag,aux
c         m scalaires: alpha
c         m vecteurs de dimension n: ybar
c         m vecteurs de dimension n: sbar
c
c     m est alors le plus grand entier tel que
c         m*(2*n+1)+4*n .le. ndz,
c     soit m := (ndz-4*n) / (2*n+1)
c     Il faut avoir m >= 1, donc ndz >= 6n+1.
c
c     A chaque iteration la metrique est formee a partir d'une matrice
c     diagonale D qui est mise a jour m fois par la formule de BFGS en
c     utilisant les m couples {y,s} les plus recents. La matrice
c     diagonale est egale apres la premiere iteration a
c         (y,s)/|y|**2 * identite (facteur d'Oren-Spedicato)
c     et est elle-meme mise a jour a chaque iteration en utilisant la
c     formule de BFGS directe diagonalisee adaptee a l'ellipsoide de
c     Rayleigh. Si on note
c         D[i]:=(De[i],e[i]), y[i]:=(y,e[i]), s[i]:=(s,e[i]),
c     ou les e[i] forment une base orthonormale pour le produit scalaire
c     (.,.) que realise prosca, la formule de mise a jour de D s'ecrit:
c         D[i] := 1 / ( (Dy,y)/(y,s)/D[i] + y[i]**2/(y,s)
c                        - (Dy,y)*(s[i]/D[i])**2/(y,s)/(D**(-1)s,s) )
c
c----
c
c         arguments
c
      integer n,impres,io,mode,niter,nsim,ndz,izs(1)
      real rzs(1)
      double precision x(1),f,g(1),dxmin,df1,epsg,dz(1),dzs(1)
      external simul,prosca,ctonb,ctcab
c
c         variables locales
c
      integer ntravu,l1memo,id,igg,iprec,iaux,ialpha,iybar,isbar,m
      double precision r1,r2
      double precision ps
c
c---- impressions initiales et controle des arguments
c
      if (impres.ge.1)
     /    write (io,900) n,dxmin,df1,epsg,niter,nsim,impres
900   format (/" n1qn3: entry point"/
     /    5x,"dimension of the problem (n):",i6/
     /    5x,"absolute precision on x (dxmin):",d9.2/
     /    5x,"expected decrease for f (df1):",d9.2/
     /    5x,"relative precision on g (epsg):",d9.2/
     /    5x,"maximal number of iterations (niter):",i6/
     /    5x,"maximal number of simulations (nsim):",i6/
     /    5x,"printing level (impres):",i4)
      if (n.le.0.or.niter.le.0.or.nsim.le.0.or.dxmin.le.0.d0
     /    .or.epsg.le.0.d0.or.epsg.gt.1.d0) then
          mode=2
          if (impres.ge.1) write (io,901)
901       format (/" >>> n1qn3: inconsistent call")
          return
      endif
      if (ndz.lt.6*n+1) then
          mode=2
          if (impres.ge.1) write (io,902)
902       format (/" >>> n1qn3: not enough memory allocated")
          goto 904
      endif
c
c---- calcul de m et des pointeurs subdivisant la zone de travail dz
c
      ntravu=ndz-4*n
      l1memo=2*n+1
      m=ntravu/l1memo
      ntravu=m*l1memo+4*n
      if (impres.ge.1) write (io,903) ndz,ntravu,m
903   format (/,5x,"allocated memory (nrz) :",i7,/,
     /         5x,"used memory :           ",i7,/,
     /         5x,"number of updates :     ",i7,/,1x)
      id=1
      igg=id+n
      iprec=igg+n
      iaux=iprec+n
      ialpha=iaux+n
      iybar=ialpha+m
      isbar=iybar+n*m
c
c---- appel du code d"optimisation
c
      call n1qn3a (simul,prosca,ctonb,ctcab,n,x,f,g,dxmin,df1,epsg,
     /             impres,io,mode,niter,nsim,m,dz(id),dz(igg),dz(iprec),
     /             dz(iaux),dz(ialpha),dz(iybar),dz(isbar),izs,rzs,dzs)
c
c---- impressions finales
c
904   continue
      if (impres.ge.1) write (io,905) mode,niter,nsim,epsg
905   format (/,1x,79("-"),/,
     /        /," n1qn3: output mode is ",i2,
     /        /,5x,"number of iterations: ",i4,
     /        /,5x,"number of simulations: ",i6,
     /        /,5x,"realized relative precision on g: ",d9.2)
      call prosca (n,x,x,ps,izs,rzs,dzs)
      r1=sqrt(ps)
      call prosca (n,g,g,ps,izs,rzs,dzs)
      r2=sqrt(ps)
      if (impres.ge.1) write (io,906) r1,f,r2
906   format (5x,"norm of x = ",d15.8,
     /       /,5x,"f         = ",d15.8,
     /       /,5x,"norm of g = ",d15.8)
      return
      end


program catalog_no21

  integer,parameter :: n=139

  real*8 a1(n,n,n),b1(n,n,n),c1(n,n,n),d1(n,n,n),e1(n,n,n)

  do k=1,n3
     do j=1,n2
        a1(1,j,k)=b1(1,j,k)*c1(1,j,k)+d1(1,j,k)*e1(1,j,k)
        a1(2,j,k)=b1(2,j,k)*c1(2,j,k)+d1(2,j,k)*e1(2,j,k)
        a1(3,j,k)=b1(3,j,k)*c1(3,j,k)+d1(3,j,k)*e1(3,j,k)
        a1(4,j,k)=b1(4,j,k)*c1(4,j,k)+d1(4,j,k)*e1(4,j,k)
        a1(5,j,k)=b1(5,j,k)*c1(5,j,k)+d1(5,j,k)*e1(5,j,k)
        a1(6,j,k)=b1(6,j,k)*c1(6,j,k)+d1(6,j,k)*e1(6,j,k)
        a1(7,j,k)=b1(7,j,k)*c1(7,j,k)+d1(7,j,k)*e1(7,j,k)
        a1(8,j,k)=b1(8,j,k)*c1(8,j,k)+d1(8,j,k)*e1(8,j,k)
      end do
   end do

end program catalog_no21


        subroutine chrft(x, y, wr, wi, isize, lwork, itype, ifault)
c
c       Algorithm AS 117.1 Appl. Statist. (1977) vol.26, no.3
c
c       Code for complex discrete Fourier transform of a sequence of
c       general length by the Chirp-Z transform
c
        real    x(lwork), y(lwork), wr(lwork), wi(lwork)
        data    zero, one/0.0, 1.0/
c
c       Check that ISIZE and LWORK are valid
c
        ifault = 0
        if (isize .lt. 3) ifault = 1
        ii = 4
        do 1 k = 3, 20
          ii = ii * 2
          if (ii .eq. lwork) go to 3
          if (ii .gt. lwork) go to 2
    1   continue

    2   ifault = ifault + 2
    3   if (lwork .lt. 2 * isize) ifault = ifault + 4
        if (itype .eq. 0) ifault = ifault + 8
        if (ifault .ne. 0) return
c
c       Multiply by the Chirp function in the time domain
c
        call chrp(x, y, one, isize, lwork, itype)
        np1 = isize + 1
        do 4 nn = np1, lwork
          x(nn) = zero
          y(nn) = zero
    4   continue
c
c       Fourier transform the chirped series
c
        call fastf(x, y, lwork, 1)
c
c       Convolve by frequency domain multiplication with (wr, wi)
c
        do 5 nn = 1, lwork
          xwi = wi(nn)
          if (itype .lt. 0) xwi = -xwi
          z = x(nn) * wr(nn) - y(nn) * xwi
          y(nn) = x(nn) * xwi + y(nn) * wr(nn)
          x(nn) = z
    5   continue
c
c       Inverse Fourier transform
c
        call fastf(x, y, lwork, -1)
c
c       Multiply by Chirp function & gain correction
c
        gc = lwork
        if (itype .gt. 0) gc = gc/isize
        call chrp(x, y, gc, isize, lwork, itype)

        return
        end

        subroutine chfor(xray, wr, wi, jsize, lwork, mwork, ifault)
c
c       Algorithm AS 117.2 Appl. Statist. (1977) vol.26, no.3
c
c       Forward Chirp DFT for real even length input sequence
c
        real    xray(lwork), wr(mwork), wi(mwork)
        data    zero, quart, half, one, one5, two, four
     +          /0.0,  0.25,  0.5, 1.0,  1.5, 2.0,  4.0/
c
c       Check for valid JSIZE, LWORK & MWORK
c
        ifault = 0
        ii = 8
        do 1 k = 4, 21
          ii = ii * 2
          if (ii .eq. lwork) go to 3
          if (ii .gt. lwork) go to 2
    1   continue
    2   ifault = 2
    3   if (lwork .lt. 2 * jsize) ifault = ifault + 4
        if (lwork .ne. 2 * mwork) ifault = ifault + 16
        nn = jsize / 2
        if (2 * nn .ne. jsize) ifault = ifault + 32
        if (nn .lt. 3) ifault = ifault + 1
        if (ifault .ne. 0) return
        ll = mwork
c
c       Split XRAY into even and odd sequences of length n/2 placing
c       the even terms in the bottom half of XRAY as dummy real terms
c       and odd terms in the top half as dummy imaginary terms.
c
        do 4 i = 1, nn
          ii = 2 * i
          m = ll + i
          xray(m) = xray(ii)
          xray(i) = xray(ii-1)
    4   continue
c
c       Perform forward Chirp DFT on even and odd sequences.
c       IFA is not tested as possible faults have already been checked.
c
        call chrft(xray, xray(ll+1), wr, wi, nn, ll, 1, ifa)
c
c       Reorder the results according to output format.
c       First, the unique real terms.
c
        z = half * (xray(1) + xray(ll+1))
        xray(nn+1) = half * (xray(1) - xray(ll+1))
        xray(1) = z
c
c       If nn is even, terms at nn/2 + 1 and 3*nn/2 can be calculated
c
        nnn = nn / 2
        if (nn .ne. 2 * nnn) go to 5
        m = nnn + 1
        xray(m) = half * xray(m)
        mm = m + ll
        m = m + nn
        xray(m) = -half * xray(mm)
        go to 6
    5   nnn = nnn + 1
c
c       Set up trig functions for calculations of remaining
c       non-unique terms
c
    6   z = four * atan(one) / nn
        bcos = -two * (sin(z/two) ** 2)
        bsin = sin(z)
        un = one
        vn = zero
c
c       Calculate & place remaining terms in correct locations.
c
        do 7 i = 2, nnn
          z = un * bcos + un + vn * bsin
          vn = vn * bcos + vn - un * bsin
          save1 = one5 - half * (z * z + vn * vn)
          un = z * save1
          vn = vn * save1
          ii = nn + 2 - i
          m = ll + i
          mm = ll + ii
          an = quart * (xray(i) + xray(ii))
          bn = quart * (xray(m) - xray(mm))
          cn = quart * (xray(m) + xray(mm))
          dn = quart * (xray(i) - xray(ii))
          xray(i) = an + un * cn + vn * dn
          xray(ii) = two * an - xray(i)
          j = nn + i
          jj = nn + ii
          xray(j) = bn - un * dn + vn * cn
          xray(jj) = xray(j) - two * bn
    7   continue

        return
        end

        subroutine chrev(xray, wr, wi, jsize, lwork, mwork, ifault)
c
c       Algorithm AS 117.3 Appl. Statist. (1977) vol.26, no.3
c
c       Inverse Chirp DFT to give real even length sequence
c
        real    xray(lwork), wr(mwork), wi(mwork)
        data    zero, half, one, one5, two, four
     +          /0.0,  0.5, 1.0,  1.5, 2.0,  4.0/
c
c       Check for valid JSIZE, LWORK & MWORK
c
        ifault = 0
        ii = 8
        do 1 k = 4, 21
          ii = ii * 2
          if (ii .eq. lwork) go to 3
          if (ii .gt. lwork) go to 2
    1   continue
    2   ifault = 2
    3   if (lwork .lt. 2 * jsize) ifault = ifault + 4
        if (lwork .ne. 2 * mwork) ifault = ifault + 16
        nn = jsize / 2
        if (2 * nn .ne. jsize) ifault = ifault + 32
        if (nn .lt. 3) ifault = ifault + 1
        if (ifault .ne. 0) return
        ll = mwork
c
c       Reorder the spectrum; first the unique terms.
c
        z = xray(1) + xray(nn+1)
        xray(ll+1) = xray(1) - xray(nn+1)
        xray(1) = z
c
c       If nn is even then terms nn/2 + 1 and 3*nn/2 + 1 must be
c       reordered.
c
        nnn = nn / 2
        if (nn .ne. 2 * nnn) go to 4
        m = nnn + 1
        xray(m) = two * xray(m)
        mm = m + ll
        m = m + nn
        xray(mm) = -two * xray(m)
        go to 5
    4   nnn = nnn + 1
c
c       Set up trig functions for manipulation of remaining terms.
c
    5   z = four * atan(one) / nn
        bcos = -two * (sin(z/two) ** 2)
        bsin = sin(z)
        un = one
        vn = zero
c
c       Perform manipulation and reordering of remaining non-unique
c       terms.
c
        do 6 i = 2, nnn
          z = un * bcos + un + vn * bsin
          vn = vn * bcos + vn - un * bsin
          save1 = one5 - half * (z * z + vn * vn)
          un = z * save1
          vn = vn * save1
          ii = nn + 2 - i
          j = nn + i
          jj = nn + ii
          an = xray(i) + xray(ii)
          bn = xray(j) - xray(jj)
          pn = xray(i) - xray(ii)
          qn = xray(j) + xray(jj)
          cn = un * pn + vn * qn
          dn = vn * pn - un * qn
          xray(i) = an + dn
          xray(ii) = an - dn
          m = ll + i
          mm = ll + ii
          xray(m) = cn + bn
          xray(mm) = cn - bn
    6   continue
c
c       Do inverse Chirp DFT to give even and odd sequences.
c       IFA is not tested as possible faults have already been checked
c
        call chrft(xray, xray(ll+1), wr, wi, nn, ll, -1, ifa)
c
c       Interlace the results to produce the required output sequence.
c
        nnn = nn + 1
        ii = jsize + 2
        do 7 i = 1, nn
          j = nnn - i
          jj = ll + j
          m = ii - 2 * i
          mm = m - 1
          xray(m) = xray(jj)
          xray(mm) = xray(j)
    7   continue

        return
        end

      subroutine setwt(wr, wi, ksize, kwork, ifault)
c
c       Algorithm AS 117.4 Appl. Statist. (1977) vol.26, no.3
c
c       Subroutine to set up Fourier transformed Chirp function for
c       use by subroutine CHRFT.
c
      real    wr(kwork), wi(kwork)
      data    zero, one, four /0.0, 1.0, 4.0/
c
c       Check that KSIZE & KWORK are valid
c
      ifault = 0
      if (ksize .lt. 3) ifault = 1
      ii = 4
      do 1 k = 3, 20
        ii = ii * 2
        if (ii .eq. kwork) go to 3
        if (ii .gt. kwork) go to 2
    1   continue
    2   ifault = 2
    3   if (kwork .lt. 2 * ksize) ifault = ifault + 4
      if (ifault .ne. 0) return
      tc = four * atan(one) / ksize
c
c       Set up bottom segment of Chirp function
c
      do 4 nn = 1, ksize
        z = nn - 1
        z = z * z * tc
        wr(nn) = cos(z)
        wi(nn) = sin(z)
    4 continue
c
c       Clear the rest
c
      do 5 nn = ksize+1, kwork
        wr(nn) = zero
        wi(nn) = zero
    5 continue
c
c       Copy to the top segment
c
      do 6 nn = kwork-ksize+2, kwork
        ll = kwork - nn + 2
        wr(nn) = wr(ll)
        wi(nn) = wi(ll)
    6 continue
c
c       Fourier transform the Chirp function
c
      call fastf(wr, wi, kwork, 1)

      return
      end

      subroutine chrp(x, y, gc, isize, lwork, itype)
c
c       Algorithm AS 117.5 Appl. Statist. (1977) vol.26, no.3
c
c       Subroutine to multiply time series by Chirp function
c
      dimension x(lwork), y(lwork)
      data    one, four /1.0, 4.0/

      tc = four * atan(one) / isize
      do 3 nn = 1, isize
        z = nn - 1
        z = z * z * tc
        xwr = cos(z)
        xwi = -sin(z)
        if (itype .lt. 0) xwi = -xwi
        z = x(nn) * xwr - y(nn) * xwi
        y(nn) = (x(nn) * xwi + y(nn) * xwr) * gc
        x(nn) = z * gc
    3 continue

      return
      end


subroutine  BELOW (TIME,BareRadioTemp,BareEvapFlux)
  use simsphere_mod
  implicit none

! **  Below is called every time step (N+1) to update the sub-surface
! **  temp's. The lowest level has a constant temp BTEMP, whereas the
! **  the surface temp has been found previously in FLUX. Use of the
! **  leap-frog method computes sub-surface temp's at the next time
! **  step from those at the current and the previous time step. BELOW
! **  also calls WATER to update the sub-surface soil moisture status.

      real :: TE(9)=0.0 , TTT(9)=0.0 , DTDT(8)=0.0
      real :: TIME, BareRadioTemp, BareEvapFlux
      real :: TERM1=0.0, TERM2=0.0, TERM3=0.0
      integer :: NLVL1=0, I=0, K=0, dummy=0

!      INCLUDE 'modvars.h'

! **  TT(2) is the temperature at the first level below the soil.

      NLVL1 = NLVLS + 1

! **  Use the fraction of vegetation to set the boundary conditions
! **  for the 1st level in the ground (surface).

      IF ( FRVEG .EQ. 0 ) THEN
         TT(1) = OTEMP
      ELSE IF ( FRVEG .GT. 0 .AND. FRVEG .LT. 1) THEN
         TT(1) = (TG**4*FRVEG + BareRadioTemp**4 * (1-Frveg))**0.25
      ELSE IF ( FRVEG .EQ. 1 ) THEN
         TT(1) = TG
      ELSE
!   PRINT*, ' Error ... Fraction of vegetation outwith bounds '
!   STOP
   continue
      END IF

      IF (HEAT .LT. 0.0 .OR. RNET .LT. 0) THEN
          TT(1) = OTEMP
      END IF

! **  K refers to level, K=1 being the surface.

      IF ( TIME .EQ. 0 ) THEN

       DO 5 I = 1 , NLVL1
        TE(I) = TT(I)
    5  CONTINUE

      END IF

! **  TT is at time N, TE is at time N-1, TTT is at time N+1
! **  Here we represent the diffusion term ... see manual for
! **  derivation.

      DO 10 K = 2 , NLVLS

       TERM1 = KAPPA / ( XFUN(K)**2 * DEL**2 )
       TERM2 = ( TT(K+1) - 2 * TE(K) + TT(K-1) ) / DZETA**2
       TERM3 = ( TE(K+1) - TT(K-1) ) / 2 * DZETA

       DTDT(K) = TERM1 * ( TERM2 - TERM3 )

        IF ( TIME .EQ. 0 ) THEN

! **  Initial computation of TT(K) and redefinition for the future.

         TTT(K) = TE(K) + DELTA * DTDT(K)
         TT(K) = TTT(K)

       ELSE

! **  Computation of TTT(K) via leapfrog rule, along with redefinition
! **  for the future.

        TTT(K) = TE(K) + 2 * DELTA * DTDT(K)
        TE(K) = TT(K)
        TT(K) = TTT(K)

       END IF

   10 CONTINUE

 if(ptime .eq. 16) then
 dummy = 1
 endif

! **  Skip the substrate water component if WMAX > 1.

      IF ( WMAX .GT. 1 ) THEN

       W2G = 99.99
       WGG = 99.99

      ELSE

         CALL WATER (TIME,BareEvapFlux)

      END IF

      RETURN
      END


      subroutine dwdiv(ar,br,bi,cr,ci,ierr)
c!but
c
c     This subroutine dwdiv computes c=a/b where a is a real number and
c      b a complex number
c
c!Calling sequence
c
c     subroutine dwdiv(ar,br,bi,cr,ci,ierr)
c
c     ar    : double precision.
c
c     br, bi: double precision, b real and complex parts.
c
c     cr, ci: double precision, c real and complex parts.
c
      double precision ar,br,bi,cr,ci
c     c = a/b
      double precision s,d,ars,brs,bis
c
      ierr=0
      if(bi.eq.0.0d0) then
         cr=ar/br
         ci=0.0d0
      elseif(br.eq.0.0d0) then
         ci=-ar/bi
         cr=0.0d0
      else
         s = abs(br) + abs(bi)
         if (s .eq. 0.0d+0) then
            ierr=1
            cr=ar/s
            ci=0.0d0
            return
         endif
         ars = ar/s
         brs = br/s
         bis = bi/s
         d = brs**2 + bis**2
         cr = (ars*brs)/d
         ci = (-ars*bis)/d
      endif
      return
      end


c
c program superres
c
      include 'VICMAIN_FOR'
      subroutine main44

      parameter (maxsamp=10000,maxpix=50,maxns=256,maxnl=256,maxtpts=9)
      real*4 obuf(maxsamp)
      integer*2 inbuf(maxns,maxnl,maxpix)
      integer*4 unit(maxpix),nl(maxpix),ns(maxpix),pixel(2,4)
      integer*4 samp,status,count,def,ounit,ntpts(maxpix)
      real*4 s_out,l_out,intensity(maxpix),residuals(maxpix)
      real*8 sum,xcoef(4,maxpix),ycoef(4,maxpix)
      real*8 ixcoef(4,maxpix),iycoef(4,maxpix)
      real*8 c(10,4),cl(10),wts(10),c1,c2
      real*4 tpts(5,9,maxpix)
      character*100 tiepoints,listoffiles,filenames,data

c parameters
      call xveaction('SA','error')
      call xvpcnt('INP',nids)
      call xvparm('SCALE',scale,count,def,1)
      call xvparm('RESOLUTION',resolution,count,def,1)
      resolution=resolution*resolution
      call xvparm('MODE',mode,count,def,1)

c read listoffiles & open inputs.
      call xvpone('INP',listoffiles,1,100)
      open(unit=10,file=listoffiles,status='old',
     + iostat=i,access='sequential')
      if(i.gt.0)then
        write(*,*)'Error opening listoffiles file ',listoffiles
        call abend()
      endif
      do image=1,maxpix
        read(10,30,iostat=i)filenames
30      format(A100)
        if(i.gt.0)then
          call xvmessage('read error on listoffiles',' ')
          call abend()
        endif
        if(i.lt.0)  goto 10
        call xvunit(unit(image),'OLD',image,status,
     +   'U_NAME',filenames,' ')
        call xvopen(unit(image),status,'U_FORMAT','HALF',' ')
        call xvget(unit(image),status,'NL',nl(image),
     +             'NS',ns(image),' ')
       if(ns(image).gt.maxns)then
          call xvmessage('Input line length too big',' ')
          call abend()
        endif
        if(nl(image).gt.maxnl)then
          call xvmessage('Too many input lines',' ')
          call abend()
        endif
      enddo
10    nids=image-1
      close(10)
      write(*,*)nids,' input files located'

c read tiepoints file
      call xvpone('INP',tiepoints,2,100)
      open(unit=10,file=tiepoints,status='old',
     + iostat=i,access='sequential')
      if(i.gt.0)then
        write(*,*)'Error opening tiepoints file ',tiepoints
        call abend()
      endif
      k=0
11    read(10,30,iostat=i)data
      if(i.ne.0)then
        call xvmessage('Error reading tiepoints file',' ')
        call abend()
      endif
      if(data(1:7).eq.'Picture')then
        k=k+1
        if(k.gt.maxpix)then
          write(*,*)'Read too many tiepoint sets'
          call abend()
        endif
        j=0
        goto 11
      endif
      if(data(1:3).eq.'end')goto 12
      j=j+1
      if(j.gt.maxtpts)then
        write(*,*)'Read too many tiepoints for image ',k+1
        call abend()
      endif
      read(data,*)(tpts(n,j,k),n=1,5)
c     write(*,*)j,k,(tpts(n,j,k),n=1,5)
      ntpts(k)=j
      goto 11
12    if(k.ne.nids-1)then
        write(*,*)'Unexpected # tiepoint sets.'
        write(*,*)'Read ',k,' expected ',nids-1
        call abend()
      endif
      close(10)

c Compute polynomials mapping first image to all the others.
c tpts(1,*)=reference line
c tpts(2,*)=reference sample
c tpts(3,*)=line
c tpts(4,*)=samp
c tpts(5,*)=quality
c line=ycoef(1)*refline+ycoef(2)*refsamp+ycoef(3)
c samp=xcoef(1)*refline+xcoef(2)*refsamp+xcoef(3)

      if(mode.eq.2)then            ! affine polynomial
        do image=1,nids-1
          do i=1,ntpts(image)
            c(i,1)=tpts(1,i,image)
            c(i,2)=tpts(2,i,image)
            c(i,3)=1.d0
            cl(i)=tpts(3,i,image)
            wts(i)=tpts(5,i,image)
          enddo
          call lsqp(ind,ntpts(image),3,c,cl,wts,ycoef(1,image+1))
          if(ind.ne.0)write(*,*)'LSQP error'
          do i=1,ntpts(image)
            c(i,1)=tpts(1,i,image)
            c(i,2)=tpts(2,i,image)
            c(i,3)=1.d0
            cl(i)=tpts(4,i,image)
            wts(i)=tpts(5,i,image)
          enddo
          call lsqp(ind,ntpts(image),3,c,cl,wts,xcoef(1,image+1))
          if(ind.ne.0)write(*,*)'LSQP error'
        enddo
      endif

      if(mode.eq.1)then            ! offset only
        do image=1,nids-1
          dy=0.
          dx=0.
          do i=1,ntpts(image)
            dy=dy+tpts(3,i,image)-tpts(1,i,image)
            dx=dx+tpts(4,i,image)-tpts(2,i,image)
          enddo
          dx=dx/ntpts(image)
          dy=dy/ntpts(image)
          xcoef(1,image+1)=0.d0
          xcoef(2,image+1)=1.d0
          xcoef(3,image+1)=dx
          ycoef(1,image+1)=1.d0
          ycoef(2,image+1)=0.d0
          ycoef(3,image+1)=dy
        enddo
      endif

      xcoef(1,1)=0.d0 ! reference image to itself.
      xcoef(2,1)=1.d0
      xcoef(3,1)=0.d0
      ycoef(1,1)=1.d0
      ycoef(2,1)=0.d0
      ycoef(3,1)=0.d0

c check least squares for precision.
      do image=2,nids
        sum=0.d0
        do i=1,ntpts(image-1)
          y1=tpts(1,i,image-1)
          x1=tpts(2,i,image-1)
          y=ycoef(1,image)*y1+ycoef(2,image)*x1+ycoef(3,image)
          x=xcoef(1,image)*y1+xcoef(2,image)*x1+xcoef(3,image)
          dy=tpts(3,i,image-1)-y
          dx=tpts(4,i,image-1)-x
          sum=sum+sqrt(dy*dy+dx*dx)
        enddo
        residuals(image)=sum/ntpts(image-1)
      enddo
      residuals(1)=0.

c invert the polynomials
      do image=1,nids
        c1=ycoef(1,image)-ycoef(2,image)*xcoef(1,image)/xcoef(2,image)
        c2=ycoef(3,image)-ycoef(2,image)*xcoef(3,image)/xcoef(2,image)
        iycoef(1,image)=1.d0/c1
        iycoef(2,image)=-ycoef(2,image)/(xcoef(2,image)*c1)
        iycoef(3,image)=-c2/c1
        ixcoef(1,image)=-xcoef(1,image)/xcoef(2,image)
        ixcoef(2,image)=1.d0/xcoef(2,image)
        ixcoef(3,image)=-xcoef(3,image)/xcoef(2,image)
      enddo

c read inputs into memory
      do image=1,nids
        do j=1,nl(image)
          call xvread(unit(image),inbuf(1,j,image),status,' ')
        enddo
      enddo

c determine size of output as largest input * scale
      nlo=0
      nso=0
      do image=1,nids
        nlo=max(nlo,int(scale*nl(image)))
        nso=max(nso,int(scale*ns(image)))
      enddo
      if(nso.gt.maxsamp)then
        call xvmessage('Output line length too big',' ')
        call abend()
      endif

c determine intensities of each input
      do image=1,nids
        sum=0.d0
        count=0
        do j=1,nl(1)
          do i=1,ns(1)
            iy=nint(ycoef(1,image)*j+ycoef(2,image)*i+ycoef(3,image))
            ix=nint(xcoef(1,image)*j+xcoef(2,image)*i+xcoef(3,image))
            if((ix.ge.1).and.(ix.le.ns(image)).and.(iy.ge.1).and.
     +         (iy.le.nl(image)))then
              count=count+1
              sum=sum+inbuf(ix,iy,image)
            endif
          enddo
          count=count+k
        enddo
        intensity(image)=sum/count
      enddo
      do image=nids,1,-1
        intensity(image)=intensity(1)/intensity(image)
      enddo

c print out status
      call xvmessage('   least squares   intensity',' ')
      call xvmessage('   residuals       correction',' ')
      do image=1,nids
        write(*,15)residuals(image),intensity(image)
15      format(2f13.6)
      enddo

c open output
      call xvunit(ounit,'OUT',1,status,' ')
      call xvopen(ounit,status,'U_FORMAT','REAL',
     +   'O_FORMAT','HALF','U_NL',nlo,'U_NS',nso,'OP','WRITE',' ')

c compute offset relating output to reference input
      offset=1.0-(scale+1.0)/(2.0*scale)
      offset=0.

c process image data.
c input picture 1 is the reference image.
      do line=1,nlo                     ! output line
        do samp=1,nso                   ! output sample

c         convert from output to location in first input.
          y1=line/scale+offset          ! reference input line
          x1=samp/scale+offset          ! reference input sample
          k=0
          sum1=0.0
          sum2=0.0

          do image=1,nids               ! input image

c           get sub pixel location in the input images.
            y=ycoef(1,image)*y1+ycoef(2,image)*x1+ycoef(3,image)
            x=xcoef(1,image)*y1+xcoef(2,image)*x1+xcoef(3,image)

c           get 4 nearest input pixels.
            ix=x
            iy=y
            pixel(1,1)=iy
            pixel(2,1)=ix
            pixel(1,2)=iy+1
            pixel(2,2)=ix
            pixel(1,3)=iy
            pixel(2,3)=ix+1
            pixel(1,4)=iy+1
            pixel(2,4)=ix+1

            do kk=1,4
              iy=pixel(1,kk)
              ix=pixel(2,kk)
              if((ix.ge.1).and.(ix.le.ns(image)).and.(iy.ge.1).and.
     +           (iy.le.nl(image)))then

                dnin=inbuf(ix,iy,image)*intensity(image)  ! input dn's

c               get sub pixel location of nearest pixel in first input.
c               the lone y below is not a syntax error !
                y=iycoef(1,image)*iy+iycoef(2,image)*ix+iycoef(3,image)
                x=ixcoef(1,image)*y+ixcoef(2,image)*ix+ixcoef(3,image)

c               get output pixel location.
                s_out=scale*(x-offset)    ! output sub pixel samp
                l_out=scale*(y-offset)    ! output sub pixel line
                r=(s_out-samp)**2+(l_out-line)**2 ! range
                if(r.lt.resolution)r=resolution
                sum1=sum1+dnin/r
                sum2=sum2+1.0/r
                k=k+1
              endif
            enddo
          enddo
          if(k.gt.0)then
            obuf(samp)=sum1/sum2
          else
            obuf(samp)=0.0
          endif
        enddo
        call xvwrit(ounit,obuf,status,' ')       ! output line

      enddo
      return
      end

c**************************************************************
      SUBROUTINE LSQP(ind,NE,NU,C,CL,wts,X1)
C
C1    GENERAL LEAST SQUARES SOLUTION OF NE EQUATIONS WITH NU UNKNOWNS,
C     C(I,1)*X1(1)+C(I,2)*X1(2)+...+C(I,NU)=CL(I) OF EQUAL WEIGHTS,WITH
C     I RANGING FROM 1 TO NE.
C
C2    THE INFORMATION FROM THE MAIN PROGRAM IS:
C          C(I,J) = COEFFICIENT MATRIX
C          CL(I) = ARRAY OF FREE TERMS
C          NE = NUMBER OF EQUATIONS
C          NU=NUMBER OF UNKNOWNS
c          wts=weight for each input point
C
C3    THE INFORMATION RETURNED TO THE MAIN PROGRAM IS:
C          X1(J) = COMPUTED VALUES OF THE UNKNOWNS
C
C5    ALL THE STATEMENTS BELOW ARE VALID FOR ANY NU LARGER THAN 1 AND
C     ANY NE LARGER THAN NU.
C
      REAL*8  A(4,4),AL(4),R(4,4),RL(4),Q(4,4),X(4),SUM
      REAL*8 C(10,4),CL(10),X1(4),wts(10)

      ind=0
      DO 57 J = 1,NU
      DO 57 I=1,NU
      A(I,J)=0.
      R(I,J)=0.
57    Q(I,J)=0.
      DO 100 I=1,NU
      DO 100 J=1,NU
      DO 100 K=1,NE
100   A(I,J)=A(I,J)+C(K,I)*C(K,J)*wts(k)
      DO 102 I=1,NU
      AL(I)=0.
      DO 102 K=1,NE
102   AL(I)=AL(I)+C(K,I)*CL(K)*wts(k)
      NUM=NU-1
      NUP=NU+1
      DO 110 I=1,NUM
      K=I+1
      DO 110 J=K,NU
      if(a(i,i).eq.0.d0)goto 999
      R(I,J)=A(I,J)/A(I,I)
      DO 110 L=1,I
110   A(K,J)=A(K,J)-R(L,K)*A(L,J)
      if(a(1,1).eq.0.d0)goto 999
      RL(1)=AL(1)/A(1,1)
      DO 125 I=2,NU
      DO 122 J=1,I
122   AL(I)=AL(I)-R(J,I)*AL(J)
      if(a(i,i).eq.0.d0)goto 999
125   RL(I)=AL(I)/A(I,I)
       X(NU)=RL(NU)
      DO 131 I=1,NUM
      IX=NU-I
      IXI=IX+1
      SUM=0.
      DO 130 J=IXI,NU
130   SUM=SUM-R(IX,J)* X(J)
131    X(IX)=RL(IX)+SUM
      DO 200 J=1,NU
200   X1(J)=X(J)
      RETURN
999   ind=1
      return
      END


!==========================================================================
elemental function gsw_helmholtz_energy_ice (t, p)
!==========================================================================
!
!  Calculates the Helmholtz energy of ice.
!
!  t  =  in-situ temperature (ITS-90)                             [ deg C ]
!  p  =  sea pressure                                              [ dbar ]
!         ( i.e. absolute pressure - 10.1325 dbar )
!
!  Helmholtz_energy_ice  =  Helmholtz energy of ice                [ J/kg ]
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_gibbs_ice

use gsw_mod_teos10_constants, only : gsw_p0, db2pa

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: t, p

real (r8) :: gsw_helmholtz_energy_ice

gsw_helmholtz_energy_ice = gsw_gibbs_ice(0,0,t,p) &
                           - (db2pa*p + gsw_p0)*gsw_gibbs_ice(0,1,t,p)

return
end function

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


! email: personal@auliakhalqillah.com
program bilanganganjil
    implicit none
    integer :: i,n
    real :: xodd

    write(*,*) 'Bilangan Ganjil'
    n = 10 ! banyak data
    xodd = 1 ! inisial bilangan ganjil
    do i = 1,n
        write(*,*) xodd
        xodd = xodd + 2
    end do

end program


SUBROUTINE median(x2, n, xmed)

! Find the median of X2(1), ... , X2(N), using as much of the quicksort
! algorithm as is needed to isolate it.

!     Latest revision - 26 November 1996
!	  From A. Miller repository
!	  Modified to take real type from module share, C. Allende Prieto 2011
!	  Changed input array from x to x2, so that it is not changed, CAP 2017

use share, only: dp

IMPLICIT NONE

INTEGER, INTENT(IN)                    :: n
REAL(dp), INTENT(IN), DIMENSION(n)     :: x2
REAL(dp), INTENT(OUT)                  :: xmed

! Local variables
REAL(dp), DIMENSION(n)  :: x
REAL(dp):: temp, xhi, xlo, xmax, xmin
LOGICAL :: odd
INTEGER :: hi, lo, nby2, nby2p1, mid, i, j, k

!make a copy to avoid altering it
x=x2

nby2 = n / 2
nby2p1 = nby2 + 1
odd = .true.

!     HI & LO are position limits encompassing the median.

IF (n == 2 * nby2) odd = .false.
lo = 1
hi = n
IF (n < 3) THEN
  IF (n < 1) THEN
    xmed = 0.0
    RETURN
  END IF
  xmed = x(1)
  IF (n == 1) RETURN
  xmed = 0.5*(xmed + x(2))
  RETURN
END IF

!     Find median of 1st, middle & last values.

10 mid = (lo + hi)/2
xmed = x(mid)
xlo = x(lo)
xhi = x(hi)
IF (xhi < xlo) THEN          ! Swap xhi & xlo
  temp = xhi
  xhi = xlo
  xlo = temp
END IF
IF (xmed > xhi) THEN
  xmed = xhi
ELSE IF (xmed < xlo) THEN
  xmed = xlo
END IF

! The basic quicksort algorithm to move all values <= the sort key (XMED)
! to the left-hand end, and all higher values to the other end.

i = lo
j = hi
50 DO
  IF (x(i) >= xmed) EXIT
  i = i + 1
END DO
DO
  IF (x(j) <= xmed) EXIT
  j = j - 1
END DO
IF (i < j) THEN
  temp = x(i)
  x(i) = x(j)
  x(j) = temp
  i = i + 1
  j = j - 1

!     Decide which half the median is in.

  IF (i <= j) GO TO 50
END IF

IF (.NOT. odd) THEN
  IF (j == nby2 .AND. i == nby2p1) GO TO 130
  IF (j < nby2) lo = i
  IF (i > nby2p1) hi = j
  IF (i /= j) GO TO 100
  IF (i == nby2) lo = nby2
  IF (j == nby2p1) hi = nby2p1
ELSE
  IF (j < nby2p1) lo = i
  IF (i > nby2p1) hi = j
  IF (i /= j) GO TO 100

! Test whether median has been isolated.

  IF (i == nby2p1) RETURN
END IF
100 IF (lo < hi - 1) GO TO 10

IF (.NOT. odd) THEN
  xmed = 0.5*(x(nby2) + x(nby2p1))
  RETURN
END IF
temp = x(lo)
IF (temp > x(hi)) THEN
  x(lo) = x(hi)
  x(hi) = temp
END IF
xmed = x(nby2p1)
RETURN

! Special case, N even, J = N/2 & I = J + 1, so the median is
! between the two halves of the series.   Find max. of the first
! half & min. of the second half, then average.

130 xmax = x(1)
DO k = lo, j
  xmax = MAX(xmax, x(k))
END DO
xmin = x(n)
DO k = i, hi
  xmin = MIN(xmin, x(k))
END DO
xmed = 0.5*(xmin + xmax)

RETURN
END SUBROUTINE median