!!Contains the subroutines needed to find a niggli reduced
!!cell and to identify it.

Module niggli
  use vector_matrix_utilities, only: determinant
  use numerical_utilities
  use num_types
  implicit none
  private
  public reduce_cell, id_cell

CONTAINS

  !!Finds the niggli reduced cell from the users given
  !!cell.
  !!<parameter name="IN" regular="true">A 3 by 3 matrix with the basis
  !!vectors as columns.</parameter>
  !!<parameter name="eps_" regular="true">Optional floating point
  !!tolerance.</parameter>
  !!<parameter name="path_" regular="true">An optional bool, true if
  !!the reduction path is to be printed at the end.</parameter>
  !!<parameter name="n_cell" regular="true">The niggli reduced
  !!cell.</parameter>
  !!<parameter name="trans" regular="true">The transformation
  !!matrix.</parameter>
  SUBROUTINE reduce_cell(IN,n_cell,trans,eps_,path_)
    real(dp), intent(in) :: IN(3,3)
    real(dp), intent(in), optional :: eps_
    logical, intent(in), optional :: path_
    real(dp), intent(out) :: n_cell(3,3)
    integer, intent(out) :: trans(3,3)

    !!<local name="vol">The vol of the input matrix.</local>
    !!<local name="eps">The floating point tolerance.</local>
    !!<local name="path">The path taken by the reduction.</local>
    !!<local name="A">The square of the first lattice vector.</local>
    !!<local name="B">The square of the second lattice vector.</local>
    !!<local name="C">The square of the third lattice vector.</local>
    !!<local name="xi">Twice the angle between the 2nd and 3rd lattice
    !!vectors.</local>
    !!<local name="eta">Twice the angle between the 3nd and 1st lattice
    !!vectors.</local>
    !!<local name="zeta">Twice the angle between the 1st and 2nd lattice
    !!vectors.</local>
    !!<local name="l">The sign of xi.</local>
    !!<local name="m">The sign of eta.</local>
    !!<local name="n">The sign of zeta.</local>
    !!<local name="reduced">True if the cell is reduced.</local>
    !!<local name="count">The number of passes through the steps that
    !!have been taken.</local>
    !!<local name="temp_lat">A temporary lattice.</local>
    !!<local name="temp_M">Temporary transoframtion matrix.</local>
    real(dp) :: vol, eps, temp_lat(3,3)
    character(len=2000):: path
    real(dp) :: A, B, C, xi, eta, zeta
    integer :: l, m, n, count, temp_M(3,3)
    logical :: reduced

    vol = determinant(IN)

    if (equal(vol,0._dp,0.000001_dp)) stop "Input matrix is linearly dependent."

    if (present(eps_)) then
       eps = eps_*abs(vol)**(1.0_dp/3.0_dp)
    else
       eps = (10.0_dp**(-5.0_dp))*abs(vol)**(1.0_dp/3.0_dp)
    end if

    path = ''
    count = 0
    reduced = .False.
    trans = transpose(reshape((/ 1, 0, 0, 0, 1, 0, 0, 0, 1 /),(/3,3/)))

    call get_params(IN,eps,A,B,C,xi,eta,zeta,l,m,n)

    do while ((.not. reduced) .and. (count <= 1000))
       reduced = .True.
       count = count + 1
       ! step #1
       if ((A>(B+eps)) .or. ((.not. (ABS(A-B)>eps)) .and. (ABS(xi)>(ABS(eta)+eps))))then
          path = trim(path) // "1"
          reduced = .False.
          trans = matmul(trans,transpose(reshape((/0, -1, 0, -1, 0, 0, 0, 0, -1/),(/3,3/))))
          temp_lat = matmul(IN,trans)
          call get_params(temp_lat,eps,A,B,C,xi,eta,zeta,l,m,n)
       end if

       ! step #2
       if ((B>(C+eps)) .or. ((.not. (ABS(C-B)>eps) .and. (ABS(eta)>ABS(zeta)+eps)))) then
          path = trim(path) // "2"
          reduced = .False.
          trans = matmul(trans, transpose(reshape((/-1, 0, 0, 0, 0, -1, 0, -1, 0/),(/3,3/))))
          temp_lat = matmul(IN,trans)
          call get_params(temp_lat,eps,A,B,C,xi,eta,zeta,l,m,n)
          cycle
       end if

       ! step #3
       if (l*m*n==1) then
          path = trim(path) // "3"
          call find_C3(l,m,n,temp_M)
          if (.not. (all(abs(temp_M-transpose(reshape((/1, 0, 0, 0, 1, 0, 0, 0, 1/),(/3,3/))))==0))) then
             reduced = .False.
          end if
          trans = matmul(trans,temp_M)
          temp_lat = matmul(IN,trans)
          call get_params(temp_lat,eps,A,B,C,xi,eta,zeta,l,m,n)
       end if

       ! step #4
       if ((l*m*n==0) .or. (l*m*n==(-1))) then
          path = trim(path) // "4"
          call find_C4(l,m,n,temp_M)
          if (.not. (all(abs(temp_M-transpose(reshape((/1, 0, 0, 0, 1, 0, 0, 0, 1/),(/3,3/))))==0))) then
             reduced = .False.
          end if
          trans = matmul(trans,temp_M)
          temp_lat = matmul(IN,trans)
          call get_params(temp_lat,eps,A,B,C,xi,eta,zeta,l,m,n)
       end if

       ! step #5
       if ((ABS(xi)>(B+eps)) .or. ((.not. (ABS(B-xi)>eps)) .and. (2.0_dp*eta<(zeta-eps))) .or. ((.not. (ABS(B+xi)>eps)) .and. (zeta<(-eps)))) then
          path = trim(path) // "5"
          reduced = .False.
          trans = matmul(trans,transpose(reshape((/1, 0, 0, 0, 1, -get_sign(xi), 0, 0, 1/),(/3,3/))))
          temp_lat = matmul(IN,trans)
          call get_params(temp_lat,eps,A,B,C,xi,eta,zeta,l,m,n)
          cycle
       end if

       ! step #6
       if ((ABS(eta)>(A+eps)) .or. ((.not. (ABS(A-eta)>eps)) .and. (2.0_dp*xi<(zeta-eps))) .or. ((.not. (ABS(A+eta)>eps)) .and. (zeta<(-eps)))) then
          path = trim(path) // "6"
          reduced = .False.
          trans = matmul(trans,transpose(reshape((/1, 0, -get_sign(eta), 0, 1, 0, 0, 0, 1/),(/3,3/))))
          temp_lat = matmul(IN,trans)
          call get_params(temp_lat,eps,A,B,C,xi,eta,zeta,l,m,n)
          cycle
       end if

       ! step #7
       if ((ABS(zeta)>(A+eps)) .or. ((.not. (ABS(A-zeta)>eps)) .and. (2.0_dp*xi<(eta-eps))) .or. ((.not. ABS(A+zeta)>eps) .and. (eta<(-eps)))) then
          path = trim(path) // "7"
          reduced = .False.
          trans = matmul(trans,transpose(reshape((/1, -get_sign(zeta), 0, 0, 1, 0, 0, 0, 1/),(/3,3/))))
          temp_lat = matmul(IN,trans)
          call get_params(temp_lat,eps,A,B,C,xi,eta,zeta,l,m,n)
          cycle
       end if

       ! step #8
       if (((xi+eta+zeta+A+B)<(-eps)) .or. ((.not. (ABS(xi+eta+zeta+A+B)>eps)) .and. ((2.0_dp*(A+eta)+zeta)>eps))) then
          path = trim(path) // "8"
          reduced = .False.
          trans = matmul(trans,transpose(reshape((/1, 0, 1, 0, 1, 1, 0, 0, 1/),(/3,3/))))
          temp_lat = matmul(IN,trans)
          call get_params(temp_lat,eps,A,B,C,xi,eta,zeta,l,m,n)
          cycle
       end if
    end do

    if (present(path_)) then
       if (path_) then
          print *, trim(path)
       end if
    end if

    if (count >= 1000) stop "Could not reduce the cell in 1000 iterations. This could be because of floating point error, try providing a smaller eps."

    if (.not. (condition_check(A,B,C,xi,eta,zeta,eps))) stop "Cell reduction failed to satisfy niggli conditions."

    n_cell = matmul(IN,trans)

  end SUBROUTINE reduce_cell

  !!Returns .True. if the niggli cell is completely reduced,
  !!.False. if otherwise.
  !!<parameter name="A" regular="true">The value of
  !!IN(:,1).IN(:,1)</parameter>
  !!<parameter name="B" regular="true">The value of
  !!IN(:,2).IN(:,2)</parameter>
  !!<parameter name="C" regular="true">The value of
  !!IN(:,3).IN(:,3)</parameter>
  !!<parameter name="xi" regular="true">The value of
  !!2*IN(:,2).IN(:,3)</parameter>
  !!<parameter name="eta" regular="true">The value of
  !!2*IN(:,3).IN(:,1)</parameter>
  !!<parameter name="zeta" regular="true">The value of
  !!2*IN(:,1).IN(:,2)</parameter>
  !!<parameter name="eps" regular="true">The floating point
  !!tolerance.</parameter>
  function condition_check(A,B,C,xi,eta,zeta,eps)
    logical :: condition_check
    real(dp), intent(in) :: A, B, C, xi, eta, zeta, eps

    condition_check = .True.

    if (.not. (((A-eps)>0.0_dp) .and. ((A<(B-eps)) .or. (ABS(A-B)<eps)) .and. ((B<(C-eps)) .or. (ABS(B-C)<eps)))) then
       condition_check = .False.
    end if

    if ((ABS(A-B)<eps) .and. (.not. ((ABS(xi)<(ABS(eta)-eps)) .or. (ABS(ABS(xi)-ABS(eta))<eps)))) then
       condition_check = .False.
    end if

    if ((ABS(B-C)<eps) .and. (.not. ((ABS(eta)<(ABS(zeta)-eps)) .or. (ABS(ABS(eta)-ABS(zeta))<eps)))) then
       condition_check = .False.
    end if

    if (.not. ((((xi-eps)>0.0_dp) .and. ((eta-eps)>0.0_dp) .and. ((zeta-eps)>0.0_dp)) .or. (((xi<0.0_dp) .or. (ABS(xi)<eps)) .and. ((eta<0.0_dp) .or. (ABS(eta)<eps)) .and. ((zeta<0.0_dp) .or. (ABS(zeta)<eps))))) then
       condition_check = .False.
    end if

    if (.not. ((ABS(xi)<(B-eps)) .or. (ABS(ABS(xi)-B)<eps))) then
       condition_check = .False.
    end if

    if (.not. (((ABS(eta)<(A-eps)) .or. (ABS(ABS(eta)-A)<eps)) .and. ((ABS(zeta)<(A-eps)) .or. (ABS(ABS(zeta)-A)<eps)))) then
       condition_check = .False.
    end if

    if (.not. ((C<(A+B+C+xi+eta+zeta-eps)) .or. (ABS(C-(A+B+C+xi+eta+zeta))<eps))) then
       condition_check = .False.
    end if

    if ((ABS(xi-B)<eps) .and. (.not. ((zeta<((2.0_dp*eta)-eps)) .or. (ABS(zeta-(2.0_dp*eta))<eps)))) then
       condition_check = .False.
    end if

    if ((ABS(eta-A)<eps) .and. (.not. ((zeta<((2.0_dp*xi)-eps)) .or. (ABS(zeta-(2.0_dp*xi))<eps)))) then
       condition_check = .False.
    end if

    if ((ABS(zeta-A)<eps) .and. (.not. ((eta<((2.0_dp*xi)-eps)) .or. (ABS(eta-(2.0_dp*xi))<eps)))) then
       condition_check = .False.
    end if

    if ((ABS(xi+B)<eps) .and. (.not. (ABS(zeta)<eps))) then
       condition_check = .False.
    end if

    if ((ABS(eta+A)<eps) .and. (.not. (ABS(zeta)<eps))) then
       condition_check = .False.
    end if

    if ((ABS(zeta+A)<eps) .and. (.not. (ABS(eta)<eps))) then
       condition_check = .False.
    end if

    if ((ABS(C-(A+B+C+xi+eta+zeta))<eps) .and. (.not. (((2.0_dp*A+2.0_dp*eta+zeta)<(-eps)) .or. (ABS(2.0_dp*A+2.0_dp*eta+zeta)<eps)))) then
       condition_check = .False.
    end if

  end function condition_check

  !!Finds the sign (-1,0,0) of a real number.
  !!<parameter name="a" regular="true">A real number.</parameter>
  function get_sign(a)
    integer :: get_sign
    real(dp), intent(in) :: a

    if (a>0) then
       get_sign = 1
    else if (a<0) then
       get_sign = -1
    else
       get_sign = 0
    end if
  end function get_sign

  !!Finds the transformation matrix for the operations of
  !!step 4.
  !!<parameter name="l" regular="true">The sign of xi.</parameter>
  !!<parameter name="m" regular="true">The sign of eta.</parameter>
  !!<parameter name="n" regular="true">The sign of zeta.</parameter>
  !!<parameter name="trans" regular="true">The transformation
  !!matrix.</parameter>
  SUBROUTINE find_C4(l,m,n,trans)
    integer, intent(in) :: l,m,n
    integer, intent(out) :: trans(3,3)

    integer :: i, j, k, r

    if ((l==(-1)) .and. (m==(-1)) .and. (n==(-1))) then
       i = 1
       j = 1
       k = 1
    else

       i = 1
       j = 1
       k = 1
       r = -1

       if (l==1) then
          i = -1
       else if (l==0) then
          r = 0
       end if

       if (m==1) then
          j = -1
       else if (m==0) then
          r = 1
       end if

       if (n==1) then
          k = -1
       else if (n==0) then
          r = 2
       end if

       if (i*j*k == (-1)) then
          if (r==0) then
             i = -1
          else if (r==1) then
             j = -1
          else if (r==2) then
             k = -1
          end if
       end if
    end if

    trans = transpose(reshape((/i, 0, 0, 0, j, 0, 0, 0, k/),(/3,3/)))

  end SUBROUTINE find_C4

  !!Finds the transformation matrix for the operation of step
  !!3.
  !!<parameter name="l" regular="true">The sign of xi.</parameter>
  !!<parameter name="m" regular="true">The sign of eta.</parameter>
  !!<parameter name="n" regular="true">The sign of zeta.</parameter>
  !!<parameter name="trans" regular="true">The transformation
  !!matrix.</parameter>
  SUBROUTINE find_C3(l,m,n,trans)
    integer, intent(in) :: l,m,n
    integer, intent(out) :: trans(3,3)

    integer :: i, j, k

    if (l==(-1)) then
       i = -1
    else
       i = 1
    end if

    if (m==(-1)) then
       j = -1
    else
       j = 1
    end if

    if (n==(-1)) then
       k = -1
    else
       k = 1
    end if

    trans = transpose(reshape((/i, 0, 0, 0, j, 0, 0, 0, k/),(/3,3/)))

  end SUBROUTINE find_C3

  !!Gets the G vector (A,B,C,xi,eta,zeta) for a given input
  !!matrix.
  !!<parameter name="IN" regular="true">The matrix being
  !!reduced.</parameter>
  !!<parameter name="eps" regular="true">The floating point
  !!tolerance.</parameter>
  !!<parameter name="A" regular="true">The value of
  !!IN(:,1).IN(:,1)</parameter>
  !!<parameter name="B" regular="true">The value of
  !!IN(:,2).IN(:,2)</parameter>
  !!<parameter name="C" regular="true">The value of
  !!IN(:,3).IN(:,3)</parameter>
  !!<parameter name="xi" regular="true">The value of
  !!2*IN(:,2).IN(:,3)</parameter>
  !!<parameter name="eta" regular="true">The value of
  !!2*IN(:,3).IN(:,1)</parameter>
  !!<parameter name="zeta" regular="true">The value of
  !!2*IN(:,1).IN(:,2)</parameter>
  !!<parameter name="l" regular="true">1 if xi is positive, -1 if it
  !!is negatev, 0 otherwise.</parameter>
  !!<parameter name="m" regular="true">1 if eta is positive, -1 if it
  !!is negatev, 0 otherwise.</parameter>
  !!<parameter name="n" regular="true">1 if zeta is positive, -1 if it
  !!is negatev, 0 otherwise.</parameter>
  SUBROUTINE get_params(IN,eps,A,B,C,xi,eta,zeta,l,m,n)
    real(dp), intent(in) :: IN(3,3), eps
    real(dp), intent(out) :: A, B, C, xi, eta, zeta
    integer, intent(out) :: l, m, n

    A  = dot_product(IN(:,1),IN(:,1))
    B  = dot_product(IN(:,2),IN(:,2))
    C  = dot_product(IN(:,3),IN(:,3))
    xi  = 2.0_dp*dot_product(IN(:,2),IN(:,3))
    eta  = 2.0_dp*dot_product(IN(:,3),IN(:,1))
    zeta  = 2.0_dp*dot_product(IN(:,1),IN(:,2))

    if (xi<-eps) then
       l = -1
    else if (xi>eps) then
       l = 1
    else
       l = 0
    end if

    if (eta<-eps) then
       m = -1
    else if (eta>eps) then
       m = 1
    else
       m = 0
    end if

    if (zeta<-eps) then
       n = -1
    else if (zeta>eps) then
       n = 1
    else
       n = 0
    end if

  end SUBROUTINE get_params

  !!Identifies which of the niggli cells is currently being
  !!used.
  !!<parameter name="U" regular="true">The users basis.</parameter>
  !!<parameter name="Nu" regular="true">The users niggli cell
  !!basis.</parameter>
  !!<parameter name="No" regular="true">The niggli basis for our
  !!cell.</parameter>
  !!<parameter name="O" regular="true">Our basis for the
  !!cell.</parameter>
  !!<parameter name="Cu" regular="true">The transformation for the
  !!users basis.</parameter>
  !!<parameter name="Co" regular="true">The transformaiton for our
  !!basis.</parameter>
  !!<parameter name="id" regular="true">The niggli cell
  !!number.</parameter>
  !!<parameter name="s_range" regular="true">The range of determinant
  !!sizes to search over.</parameter>
  !!<parameter name="eps_" regular="true">Optional floating point
  !!tolerance.</parameter>
  SUBROUTINE id_cell(U, Nu, Cu, O, No, Co, id, s_range, eps_)
    real(dp), intent(in) :: U(3,3)
    real(dp), intent(in), optional :: eps_
    real(dp), intent(out) :: O(3,3), Nu(3,3), No(3,3)
    integer, intent(out) :: Cu(3,3), Co(3,3)
    integer, intent(out) :: id, s_range

    real(dp) :: eps
    real(dp) :: temp_a(3), temp_b(3), temp_c(3), A, B, C, D, E, F
    logical :: positive

    if (present(eps_)) then
       eps = eps_
    else
       eps = (10.0_dp**(-5.0_dp))
    end if

    call reduce_cell(U,Nu,Cu,eps_=eps)
    !! Integer transformation check TODO

    temp_a = Nu(:,1)
    temp_b = Nu(:,2)
    temp_c = Nu(:,3)

    A = dot_product(temp_a,temp_a)
    B = dot_product(temp_b,temp_b)
    C = dot_product(temp_c,temp_c)
    D = dot_product(temp_b,temp_c)
    E = dot_product(temp_a,temp_c)
    F = dot_product(temp_a,temp_b)

    positive = .False.
    if (((D-eps)>0) .and. ((E-eps)>0) .and. ((F-eps)>0)) then
       positive = .True.
    end if

    id = (-1)
    if (isclose(A,B,atol_=eps) .and. isclose(B,C,atol_=eps)) then !!lengths the same
       if (positive .eqv. .True.) then !! all angles acute?
          if (isclose(D,E,atol_=eps) .and. isclose(D,F,atol_=eps)) then !!all angles the same?
             if (isclose((A/2.0_dp),D,atol_=eps)) then
                id = 1 !! fcc
                s_range = 1
                O = reshape((/0.0_dp, 1.0_dp, 1.0_dp, 1.0_dp, 0.0_dp, 1.0_dp, 1.0_dp, &
                     1.0_dp, 0.0_dp/),(/3,3/))
             else
                id = 2 !! Acute Rhombohedral, angles not 90 or 60 but all the same
                s_range = 25
                O = reshape((/-1.11652_dp, -0.610985_dp, 0.616515_dp, 0.0_dp, &
                     -1.32288_dp, -0.5_dp, 1.0_dp, 1.32288_dp, 1.5_dp/),(/3,3/))
             end if
          end if
       else !! not acute angles.
          if (isclose(D,E,atol_=eps) .and. isclose(D,F,atol_=eps)) then !! all angles the same.
             if (isclose(0.0_dp,D,atol_=eps)) then !! all angles close to 0.
                id = 3 !! simple cubic.
                s_range = 1
                O = reshape((/1.0_dp, 0.0_dp, 0.0_dp, 0.0_dp, 1.0_dp, 0.0_dp, 0.0_dp, &
                     0.0_dp, 1.0_dp/),(/3,3/))
             else if (isclose((-A/3.0_dp),D,atol_=eps)) then
                id = 5 !! bcc
                s_range = 1
                O = reshape((/-1.0_dp, 1.0_dp, 1.0_dp, 1.0_dp, -1.0_dp, 1.0_dp, &
                     1.0_dp, 1.0_dp, -1.0_dp/),(/3,3/))
             else
                id = 4 !! Obtuse Rhombohedral, angles not 90 or 60 but all the same
                s_range = 25
                O = reshape((/-0.548584_dp, 0.774292_dp, 1.04858_dp, 0.0_dp, &
                     -1.32288_dp, 0.5_dp, 1.0_dp, 1.32288_dp, 0.5_dp/),(/3,3/))
             end if
          else if (isclose((2.0_dp*ABS(D+E+F)),(A+B),atol_=eps)) then !! not all angles the same.
             if (isclose(D,E,atol_=eps)) then
                id = 6 !! body-centered Tetragonal
                s_range = 25
                O = reshape((/1.80278_dp, -1.47253_dp, 0.762655_dp, 2.80278_dp, &
                     0.13535_dp, -0.791285_dp, 0.80278_dp, -0.47253_dp, 2.762655_dp/),(/3,3/))
             else if (isclose(E,F,atol_=eps)) then
                id = 7 !! body-centered Tetragonal
                s_range = 25
                O = reshape((/1.95095_dp, 1.19163_dp, 0.879663_dp, 0.0_dp, &
                     2.60788_dp, 0.44606_dp, 0.95095_dp, -0.41625_dp, 2.433603_dp/),(/3,3/))
             else
                id = 8 !! body-centered Orthorhombic
                s_range = 15
                O = reshape((/1.41144_dp, 0.0885622_dp, -2.0_dp, -0.99868_dp, 2.21232_dp,&
                     1.268178_dp, 3.41012_dp, -1.1237578_dp, -1.268178_dp/),(/3,3/))
             end if
          end if !! 2|D+E+F|==(A+B)
       end if !! are the angles acute?
    end if !! are all the lattice vector lengths the same?

    if (isclose(A,B,atol_=eps) .and. (id==(-1))) then !! A==B!=C
       if (positive .eqv. .True.) then !! all angles acute.
          if (isclose(D,E,atol_=eps) .and. isclose(D,F,atol_=eps) .and. &
               isclose((A/2.0_dp),D,atol_=eps)) then !! all angles the same and 60 degrees.
             id = 9 !! Hexagonal Rhombohedral
             s_range = 25
             O = reshape((/1.0_dp, 2.0_dp, 2.0_dp, 2.0_dp, 1.0_dp, 2.0_dp, 4.0_dp, &
                  3.0_dp, 3.0_dp/),(/3,3/))
          else if (isclose(D,E,atol_=eps)) then
             id = 10 !! base-centered Monoclinic
             s_range = 10
             O = reshape((/1.0_dp, -1.0_dp, 1.0_dp, -1.46391_dp, 0.0_dp, 1.96391_dp, &
                  0.0_dp, 2.0_dp, 0.0_dp/),(/3,3/))
          end if
       else !! some angles obtuse.
          if (isclose(D,E,atol_=eps) .and. isclose(D,F,atol_=eps) .and. &
               isclose(0.0_dp,D,atol_=eps)) then !! all angles close to 0.
             id = 11 !! Primitive Tetragonal
             s_range = 25
             O = reshape((/1.0_dp, 0.0_dp, 0.0_dp, 0.0_dp, 1.0_dp, 0.0_dp, 0.0_dp, &
                  0.0_dp, 2.0_dp/),(/3,3/))
          else if (isclose(D,E,atol_=eps)) then !! two angles the same
             if (isclose(0.0_dp,D,atol_=eps) .and. isclose((-A/2.0_dp),F,atol_=eps)) then !! D==E==0 and F==120
                id = 12 !! Primitive Hexagonal 120 degrees.
                s_range = 25
                O = reshape((/1.0_dp, 0.0_dp, 0.0_dp, 0.5_dp, -0.8660254037844386_dp, &
                     0.0_dp, 0.0_dp, 0.0_dp, 2.0_dp/),(/3,3/))
             else if (isclose((-A/2.0_dp),D,atol_=eps) .and. isclose(0.0_dp,F,atol_= eps)) then !! D==E==120 and F==0
                id = 15 !! body-centered Tetragonal
                s_range = 25
                O = reshape((/-1.0_dp, -1.0_dp, 2.0_dp, 0.0_dp, -2.0_dp, 0.0_dp, -2.0_dp, &
                     0.0_dp, 0.0_dp/),(/3,3/))
             else if (isclose(0.0_dp,D,atol_=eps)) then !! D==E==0 and no constraint on F.
                id = 13 !! base-centered Orthorhombic
                s_range = 15
                O = reshape((/1.0_dp, 1.0_dp, 1.0_dp, 1.0_dp, -1.0_dp, -1.0_dp, 0.0_dp, &
                     -1.73205_dp, 1.73205_dp/),(/3,3/))
             else if (isclose((2.0_dp*ABS(D+E+F)),(A+B),atol_=eps)) then !! 2|D+E+F|==(A+B)
                id = 16 !! face-centered Orthorhombic
                s_range = 20
                O = reshape((/1.04442_dp, 1.43973_dp, 1.68415_dp, 0.779796_dp, -1.1789_dp, &
                     1.0_dp, 1.779796_dp, -0.1789_dp, 0.0_dp/),(/3,3/))
             else
                id = 14 !! base-centered Monoclinic
                s_range = 10
                O = reshape((/-1.0_dp, 1.0_dp, 0.0_dp, 0.5_dp, 0.0_dp, 2.0_dp, 0.0_dp, &
                     -2.0_dp, 0.0_dp/),(/3,3/))
             end if
          else if (isclose((2.0_dp*ABS(D+E+F)),(A+B),atol_=eps)) then
             id = 17 !! base-centered Monoclinic
             s_range = 10
             O = reshape((/-1.05387_dp, -1.61088_dp, 1.51474_dp, -0.244302_dp, -2.77045_dp, &
                  0.51474_dp, 1.809568_dp, -0.15957_dp, 0.0_dp/),(/3,3/))
          end if
       end if !! acute or obtuse angles.
    end if !! A==B!=C

    if (isclose(B,C,atol_=eps) .and. (id==(-1))) then !! B==C!=A
       if (positive .eqv. .True.) then !! all angles acute
          if (isclose(E,F,atol_=eps)) then !! E==F
             if (isclose((A/4.0_dp),D,atol_=eps) .and. isclose((A/2.0_dp),E,atol_=eps)) then
                id = 18
                s_range = 25
                O = reshape((/-2.0_dp, -1.0_dp, 1.0_dp, -3.0_dp, 1.0_dp, 0.0_dp, -1.0_dp, &
                     -3.0_dp, 0.0_dp/),(/3,3/))
             else if (isclose((A/2.0_dp),E,atol_=eps)) then
                id = 19
                s_range = 15
                O = reshape((/0.5_dp, 1.0_dp, 1.5_dp, 0.0_dp, 2.0_dp, 0.0_dp, 0.0_dp, &
                     0.0_dp, 3.0_dp/),(/3,3/))
             else
                id = 20
                s_range = 10
                O = reshape((/1.0_dp, 1.0_dp, 1.0_dp, 1.70119_dp, -1.45119_dp, 1.0_dp, &
                     0.69779_dp, -1.4322505_dp, 3.23446_dp/),(/3,3/))
             end if
          end if
       else
          if (isclose(E,F,atol_= eps)) then
             if (isclose(0.0_dp,D,atol_=eps) .and. isclose(0.0_dp,E,atol_=eps)) then
                id = 21
                s_range = 25
                O = reshape((/0.0_dp, 0.0_dp, 0.5_dp, 1.0_dp, 0.0_dp, 0.0_dp, 0.0_dp, &
                     1.0_dp, 0.0_dp/),(/3,3/))
             else if (isclose((-B/2.0_dp),D,atol_=eps) .and. isclose(0.0_dp,E,atol_=eps)) then
                id = 22
                s_range = 25
                O = reshape((/0.0_dp, 0.0_dp, -0.5_dp, 1.0_dp, 0.0_dp, 0.0_dp, &
                     -0.5_dp, 0.8660254037844386_dp, 0.0_dp/),(/3,3/))
             else if (isclose(0.0_dp,E,atol_=eps)) then
                id = 23
                s_range = 15
                O = reshape((/-0.3333333_dp, -1.54116_dp, 1.87449_dp, 1.0_dp, 1.0_dp, &
                     1.0_dp, 2.0_dp, -1.0_dp, -1.0_dp/),(/3,3/))
             else if (isclose((2.0_dp*ABS(D+E+F)),(A+B),atol_=eps) .and. &
                  isclose((-A/3.0_dp),E,atol_=eps)) then
                id = 24
                s_range = 25
                O = reshape((/-0.255922_dp, -1.44338_dp, 0.92259_dp, 1.51184_dp, &
                     0.0_dp, -0.845178_dp, 1.255922_dp, 1.44338_dp, 0.07741_dp/),(/3,3/))
             else
                id = 25
                s_range = 10
                O = reshape((/1.0_dp, 1.0_dp, 1.0_dp, 1.45119_dp, -1.70119_dp, &
                     -1.0_dp, 0.28878_dp, -3.26895_dp, 0.48018_dp/),(/3,3/))
             end if
          end if
       end if
    end if

    if (id==(-1)) then
       if (positive .eqv. .True.) then
          if (isclose(E,F,atol_=eps)) then
             !! Why did we not use isclose()? TODO
             if ((ABS((A/4.0_dp)-D)<= ABS(eps*D)) .and. (ABS((A/2.0_dp)-E)<= ABS(eps*E))) then
                id = 26
                s_range = 20
                O = reshape((/0.0_dp, 1.0_dp, 1.5_dp, 0.5_dp, 0.0_dp, 1.5_dp, 0.0_dp, &
                     0.0_dp, 3.0_dp/),(/3,3/))
             else if (isclose((A/2.0_dp),E,atol_=eps)) then
                id = 27
                s_range = 10
                O = reshape((/-1.464824_dp,0.464824_dp,1.907413_dp,-0.153209_dp,0.153209_dp, &
                     -2.907413_dp,1.0_dp,1.0_dp,0.0_dp/),(/3,3/))
             else ! Default to Triclinic (same behavior as VASP)
                id = 31
                s_range = 1
                O = U
             end if
          else !! E==F
             if (isclose((A/2.0_dp),E,atol_=eps) .and. isclose((2.0_dp*D),F,atol_=eps)) then
                id = 28
                s_range = 10
                O = reshape((/-1.44896_dp, 0.948958_dp, -1.0_dp, -1.0_dp, -1.0_dp, &
                     0.0_dp, 0.342424_dp, -1.342424_dp, -2.02006_dp/),(/3,3/))
             else if (isclose((A/2.0_dp),F,atol_=eps) .and. &
                  isclose((2.0_dp*D),E,atol_=eps)) then
                id = 29
                s_range = 10
                O = reshape((/-0.666125_dp, 1.16613_dp, 2.04852_dp, 1.0_dp, 1.0_dp, &
                     0.0_dp, 1.61803_dp, -0.618034_dp, 1.0_dp/),(/3,3/))
             else if (isclose((B/2.0_dp),D,atol_=eps) .and. &
                  isclose((2.0_dp*E),F,atol_=eps)) then
                id = 30
                s_range = 10
                O = reshape((/1.0_dp, 1.0_dp, 0.0_dp, 1.61803_dp, -0.618034_dp, 1.0_dp, &
                     -0.0361373_dp, 0.536137_dp, 2.38982_dp/),(/3,3/))
             else
                id = 31
                s_range = 1
                O = U
             end if
          end if
       else
          if (isclose(E,F,atol_=eps) .and. isclose(0.0_dp,E,atol_=eps)) then
             if (isclose(0.0_dp,D,atol_=eps)) then
                id = 32
                s_range = 15
                O = reshape((/1.0_dp, 0.0_dp, 0.0_dp, 0.0_dp, 2.0_dp, 0.0_dp, 0.0_dp, &
                     0.0_dp, 3.0_dp/),(/3,3/))
             else if (isclose(D,(-B/2.0_dp),atol_=eps)) then
                id = 40
                s_range = 15
                O = reshape((/1.0_dp, 1.0_dp, 1.0_dp, 1.61803_dp, -0.618034_dp, &
                     -1.0_dp, -1.05557_dp, 1.99895_dp, -0.943376_dp/),(/3,3/))
             else
                id = 35
                s_range = 10
                O = reshape((/-0.668912_dp, 1.96676_dp, -1.29785_dp, 1.61803_dp, &
                     -0.618034_dp, -1.0_dp, 1.0_dp, 1.0_dp, 1.0_dp/),(/3,3/))
             end if
          else if (isclose(D,F,atol_=eps) .and. isclose(0.0_dp,D,atol_=eps)) then
             if (isclose((-A/2.0_dp),E,atol_=eps)) then
                id = 36
                s_range = 15
                O = reshape((/1.0_dp, 1.0_dp, 1.0_dp, 1.41421_dp, -1.41421_dp, &
                     0.0_dp, -1.43541_dp, -1.43541_dp, 1.37083_dp/),(/3,3/))
             else
                id = 33
                s_range = 10
                O = reshape((/2.0_dp, 0.0_dp, 0.0_dp, 0.0_dp, 2.0_dp, 0.0_dp, 0.5_dp, &
                     0.0_dp, 2.0_dp/),(/3,3/))
             end if
          else if (isclose(D,E,atol_=eps) .and. isclose(0.0_dp,D,atol_=eps)) then
             if (ABS((-A/2.0_dp)-F)<= ABS(eps*F)) then
                id = 38
                s_range = 15
                O = reshape((/0.5_dp, 1.0_dp, 0.0_dp, 0.5_dp, -1.0_dp, 0.0_dp, 0.0_dp, &
                     0.0_dp, 3.0_dp/),(/3,3/))
             else
                id = 34
                s_range = 10
                O = reshape((/1.0_dp, 1.0_dp, 1.0_dp, 1.22474487_dp, -1.22474487_dp, &
                     -1.0_dp, -0.16598509_dp, -1.64308297_dp, 1.80906806_dp/),(/3,3/))
             end if
          else
             if (isclose((-B/2.0_dp),D,atol_=eps) .and. isclose((-A/2.0_dp),E,atol_=eps) &
                  .and. isclose(0.0_dp,F,atol_=eps)) then
                id = 42
                s_range = 20
                O = reshape((/-1.53633_dp, 1.36706_dp, -1.33073_dp, 1.0_dp, 1.0_dp, &
                     1.0_dp, 1.61803_dp, -0.61803_dp, -1.0_dp/),(/3,3/))
             else if (isclose((-B/2.0_dp),D,atol_=eps) .and. isclose(0.0_dp,F,atol_=eps)) then
                id = 41
                s_range = 10
                O = reshape((/-1.85397_dp, -0.854143_dp, 1.35397_dp, 1.0_dp, 0.0_dp, &
                     1.0_dp, 1.0_dp, -1.41421_dp, -1.0_dp/),(/3,3/))
             else if (isclose((-A/2.0_dp),E,atol_=eps) .and. isclose(0.0_dp,F,atol_=eps)) then
                id = 37
                s_range = 10
                O = reshape((/-1.79092_dp, -1.47209_dp, 0.790922_dp, 1.0_dp, -1.41421_dp, &
                     -1.0_dp, 1.0_dp, 0.0_dp, 1.0_dp/),(/3,3/))
             else if (isclose(0.0_dp,E,atol_=eps) .and. isclose((-A/2.0_dp),F,atol_=eps)) then
                id = 39
                s_range = 10
                O = reshape((/0.0_dp, -1.73205_dp, -1.0_dp, -1.66542_dp, -0.672857_dp, &
                     1.66542_dp, 1.0_dp, 0.0_dp, 1.0_dp/),(/3,3/))
             else if (isclose((2.0_dp*ABS(D+E+F)),(A+B),atol_=eps) .and. &
                  isclose(ABS(2.0_dp*D+F),B,atol_=eps)) then
                id = 43
                s_range = 10
                O = reshape((/-0.39716_dp, -0.34718_dp, 2.49434_dp, 2.64194_dp, &
                     -0.14194_dp, 0.0_dp, -1.39716_dp, -1.34718_dp, 1.49434_dp/),(/3,3/))
             else
                id = 44
                s_range = 1
                O = U
             end if
          end if
       end if
    end if

    !! see table 9.2.5.1 in the international tables (pdf in autoGR/support/documents)
    open(5,file="autoGR.out")
    write(5,'("Niggli cell id: ",I2)') id

    call reduce_cell(O,No,Co,eps_=eps)

  end SUBROUTINE id_cell

  !!Matches the numpy allclose function for single floats.
  !!<parameter name="A" regular="true">The first value to compare.</parameter>
  !!<parameter name="B" regular="true">The second value to compare.</parameter>
  !!<parameter name="rtol_" regular="true">Relative tolerance.</parameter>
  !!<parameter name="atol_" regular="true">Absolute tolerance.</parameter>
  Function isclose(A,B,rtol_,atol_)
    logical :: isclose
    real(dp), intent(in) :: A, B
    real(dp), optional, intent(in) :: rtol_, atol_

    real(dp) :: rtol, atol

    if (present(rtol_)) then
       rtol = rtol_
    else
       rtol = 10.0_dp**(-5.0_dp)
    end if

    if (present(atol_)) then
       atol = atol_
    else
       atol = 10.0_dp**(-8.0_dp)
    end if

    if (ABS(A-B) <= (atol+rtol*ABS(B))) then
       isclose = .True.
    else
       isclose = .False.
    end if

  end Function isclose

end Module niggli


      double precision function psi(xd,yd,zd,t)
      implicit none

      double precision xd, yd, zd, t

      double precision kappa,tfinal
      common /windparms/ kappa,tfinal

      double precision pi, pi2
      common /compi/ pi, pi2

      double precision l, th, lp

c      call get_wind_parms(kappa,tfinal)

      call map2polar(xd,yd,zd,l,th)

      lp = l - 2*pi*t/tfinal

      psi = kappa*sin(lp)**2*cos(th)**2*cos(pi*t/Tfinal) -
     &      2*pi*sin(th)/Tfinal

c     # Sign difference from Benchmark problem
      psi = -psi

      end

      subroutine map2polar(x,y,z,lambda,th)
      implicit none

      double precision x,y,z,th,lambda
      double precision r

      double precision pi, pi2
      common /compi/ pi, pi2

      r = sqrt(x**2 + y**2 + z**2)
      th = asin(z/r)

      lambda = atan2(y,x)
      if (lambda .lt. 0) then
         lambda = lambda + 2*pi
      endif

      end

      subroutine get_psi_vel(xd1,xd2,ds,vn,t)
      implicit none

      double precision xd1(3),xd2(3), ds, vn, psi,t

      vn = (psi(xd1(1),xd1(2),xd1(3),t) -
     &      psi(xd2(1),xd2(2),xd2(3),t))/ds

      end


      subroutine svd_solve(m, n, mp, np, a, b, v, w, nw)
      use kind_spec
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer m, n, mp, np, nw
      real(rprec), dimension(mp,np) :: a
      real(rprec), dimension(n,n) :: v
      real(rprec), dimension(n) :: w
      real(rprec), dimension(m) :: b
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      real(rprec) :: small = 1.0e-10_dp
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: istat, i, j
      real(rprec), allocatable :: u(:,:)
C-----------------------------------------------

c       Solves Matrix equation A * V = B for V using SVD method
c       Uses svd routines from numerical recipes
c       Prashant Valanju (Dec 1998) pvalanju@mail.utexas.edu

c       Almost same as SvdSolveB except this one finds
c       nw solutions V(:,i) by keeping i = 1 to nw vectors, where
c       nw is the number of vectors with nonzero weights > small

c       It also uses V internally for SVD decomposition to save space, so

c       Inputs:
c       A(M,N) - Matrix with physical dimensions (Mp,Np)
c       B(M)   - R.H.S. of A X = B
c       M      - Number of rows of A to use
c       N      - Number of columns of A to use
c       Mp,NP  - Storage dimensions of A(Mp,Np)
c
c       Output:
c       nw      - number of vectors with normalized weights above small
c          Eventually, this will be the number of optimum weights
c          after we decide on a criterion for optimization
c       V(N,nw) - nw Solutions of A V = B, each a vector of length N
c          V(:N,iw) = solution with top iw weights kept
c          Physical dimensions of V are (N,N)
c       w(n)    - Weights in decreasing order
c

c  Allocate local arrays.
c  Note u(m,n) is enough because needed part of a(mp,np) is copied to
c  u(m,n), and a(mp,np) is never used directly. This saves space.
c  It is essential to use a local u since svdcmp changes it

      allocate (u(m,n),  stat=istat)
      if(istat.ne.0) stop 'Stop: No memory in svd_nesc'

c.......................................
c  Initialize all to zero to wipe out effects of old call
      w(:n) = 0                                !Zero all weights
      do j = 1, n
         u(:m,j) = a(:m,j)                  !Because U will be changed by svdcmp
         v(:n,j) = 0
      end do

c  Do the SVD decomposition of a, i.e, of u into u, v and w
       call svdcmp (u, m, n, m, n, w, v)

c  Sort weights and matrices with DECREASING weights so w(1) is biggest
c  Permute weight w(i) AND column vectors U(*,i), V(*,i) at the same time
       call sortsvd (m, n, m, n, w, u, v)

c  Find nw = number of large weights (dcreasing ordered by sortsvd)
         do nw = n, 1, -1          !Find first large weight and get out
            if ( abs(w(nw)/w(1)) .gt. small) exit
         end do

c  Find nw solutions by successively adding up eigenvectors V
c     with correct weight given by (U(i) dot b)/w(i) in eq 14.3.17 (NR).
c  The coeff of ith vector V(i) is the dot product of the i-th column
c     of U with the rhs vector B, divided by w(i)
c  This does the svdbksb directly, faster than the NR svdbksub routine
c     and uses less memory due to the dual role of V
c  Note: any optimization scheme to find the 'best' nw will

c      First set the 1st vector with largest weight w(1)
       v(:n,1) = sum(u(:m,1)*b(:m)) *v(:n,1) /w(1)
c      Next add the vectors with successive weights (in decreasing order)
         do i = 2, nw
            j = i - 1
            v(:n,i) = v(:n,j) + sum(u(:m,i)*b(:m)) *v(:n,i) / w(i)
         end do
c................................................

      deallocate (u, stat=istat)

!     end subroutine svd_solve
      end

      subroutine svdsolveb(m, n, mp, np, wcut, file, a, b, x)
      use kind_spec
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer m, n, mp, np
      real(rprec) wcut
      real(rprec), dimension(mp,np) :: a
      real(rprec), dimension(n) :: b, x
      character file*(*)
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      real(rprec) :: zero = 0
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: n1, nonzero, nlast, istat, i, j, iunit
      real(rprec), allocatable :: u(:,:), v(:,:), w(:)
      real(rprec) :: wmax, wmin, wcuta, udotb, err
C-----------------------------------------------

c       Solves Matrix equation A X = B for X using SVD method
c       Allows supression of weights, storage and recall of answers
c       Uses svd routines from numerical recipes
c       Prashant Valanju (Sept 1998) pvalanju@mail.utexas.edu

c       Almost same as SvdSolveUV except this one stores basis vectors
c       rather than U, w, V. This one is a bit faster than SvdSolveUV, so
c       use this one when you want to change only weights, not B or A

c       Inputs:
c       A(M,N) - Matrix with physical dimensions (Mp,Np)
c       B(N)   - R.H.S. of A X = B
c       M      - Number of rows of A to use
c       N      - Number of columns of A to use
c       Mp,NP  - Storage dimensions of A(Mp,Np)
c       Wcut  - Cutoff parameter
c                If Wcut = 0, writes answers into "file", all weights are kept
c                If Wcut < 0, reads previous answers from "file",
c                              and uses -Wcut for weights to keep
c                If 0 < Wcut < 1 : Cuts off weights with w(i)/wmax < wcut
c                      Use this to cut off small weights, does calculation
c                If Wcut = integer > 1, keeps Wcut weights, does calculation
c                      Use this to cut off fixed number of weights
c       Output:
c       X(N)   - Solution of A X = B
c
      n1 = n

c     allocate local arrays
      allocate (u(mp,np), w(np), v(np,np), stat=istat)

      if (istat .eq. 0) then                       !have enough memory

         iunit = 41

         x(:n1) = zero                    !zero answer from previous call
         wcuta = abs(wcut)
c...............................
c     If Wcut < 0 use precalculated weights to get answer fast
c        use wcuta = abs(wcut) for everything
c     If any error happens while reading "file", do full svd calculation
         if (wcut .lt. 0) then         !Read file from previous calculation
            call safe_open(iunit, istat, file, 'old', 'formatted')
            if (istat .ne. 0) goto 98
            read (iunit, *, err=98)
            read (iunit, *, err=98)
            read (iunit, *, err=98) m, n, nonzero
c                           !Read exactly the same way they were written
            do i = 1, nonzero
               read (iunit, *, err=98) w(i)         !read i-th weight
               do j = 1, n                 !read i-th basis vector/ w(i)
c                             !read j-th entry (row) of i-th column of V
                  read (iunit, *, err=98) v(j,i)
               end do
            end do
            close(unit=iunit)

c        Decide how many weights to keep
            if (wcuta .gt. 1) nlast = wcuta         !Keep Nlast weights
            if (wcuta .lt. 1) then                  !cutoff small weights
               wmax = w(1)                          !weights are already ordered
               nlast = 0
               do i = 1, nonzero
                  if (w(i) .gt. wmax*wcuta) then
                     nlast = nlast + 1              !accept this weight
                  else
                     go to 96
                  endif
               end do
            endif

c        Just find linear sum of Nlast vectors (weights were already included)
   96       continue
            if (nlast.le.0 .or. nlast.gt.nonzero) nlast = nonzero
            do i = 1, nlast             !add ith column of V(*,i) to X(*)
               x(:n) = x(:n) + v(:n,i)  !add to the j-th entry of X
            end do
            go to 999                   !all done
         endif                          !End of precalculated branch Wcut < 0
   98    continue
c.......................................
c     If Wcut .ge. 0, do full svd calculation
c     Initialize all to zero to wipe out effects of old call
         do j = 1, n
            w(j) = zero                           !Zero all weights
            u(:m,j) = a(:m,j)  !Because U will be changed by svdcmp
            v(:m,j) = zero
         end do

         call svdcmp (u, m, n, mp, np, w, v)     !Do SVD decomposition

c       Sort weights and matrices with DECREASING weights
c       Permute weight w(i) AND column vectors U(*,i), V(*,i) at the same time
         call sortsvd (m, n, mp, np, w, u, v)

c       Find the number of nonzero weights (already dcreasing ordered)
         do nonzero = n, 1, -1
c                                   !Found first nonzero weight, get out
            if (w(nonzero) .ne. 0) exit
         end do
         if (nonzero .gt. 0) then
            if (wcuta .gt. 1) then

c        Decide how many weights to keep
               nlast = wcuta                     !Keep Nlast weights
            else                                 !cutoff small weights
               wmax = w(1)                  !weights are already ordered
               nlast = 0
               do i = 1, nonzero
                  if (w(i) .gt. wmax*wcuta) then
                     nlast = nlast + 1           !accept this weight
                  else
                     go to 97
                  endif
               end do
            endif

c       Find solution X and basis vectors (put into columns of V)
   97       continue
            if (nlast.le.0 .or. nlast.gt.nonzero) nlast = nonzero
            do i = 1, nlast  !Calc i-th coeff (U.b/w) for noNonzero w(i)
c        First calculate i-th coeff (U(i)*b/w(i)) in the sum in eq 14.3.17 (NR)
c                                Dot product of i-th column of U with B
c                                summed over all plasma points
               udotb = sum(u(:m,i)*b(:m))
c                        !=(Ui.b/wi) in eq 14.3.17, saves many divisions
               udotb = udotb/w(i)
c         Now run down the i-th column of the vector V(j,i)
c                             j-th entry (row) of vectors in eq 14.3.17
c                             Now V is the basis vector times weight
               v(:n,i) = udotb*v(:n,i)
c                             add it to the j-th entry of X
               x(:n) = x(:n) + v(:n,i)
                                  !This did the svdbksb, faster than NR
            end do                !and also calculated the basis vectors

c       Write all weights and weighted basis functions into SVD file (Wcut=0)
            if (wcut .eq. 0) then
               call safe_open(iunit, istat, file, 'unknown','formatted')
               write (iunit, *) 'Max w = ', w(1), ', Min w = ',
     1                          w(nonzero)
               write (iunit, *) 'Ratio = ', w(1)/w(nonzero)
               write (iunit, *) m, n, nonzero
               do i = 1, nonzero             !write in DECREASING order of weights
                  write (iunit, *) w(i)      !write i-th weight
                  do j = 1, n                !write i-th basis vector/ w(i)
                                             !write j-th entry (row) of i-th column of V
                     write (iunit, *) v(j,i)
                  end do
               end do
               close(unit=iunit)
            endif
c................................................
         endif
      endif
  999 continue

      deallocate (u, w, v, stat=istat)

!     end subroutine svdsolveb
      end

      subroutine svdsolveuv(m, n, mp, np, wcut, file, a, b, x)
      use kind_spec
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer m, n, mp, np
      real(rprec) wcut
      character file*(*)
      real(rprec), dimension(mp,np) :: a
      real(rprec), dimension(n) :: b, x
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      real(rprec) :: zero = 0
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: n1, nonzero, nlast, istat, i, j, iunit
      real(rprec), allocatable :: u(:,:), w(:), v(:,:)
      real(rprec) :: wmax, wmin, wcuta, udotb, err
C-----------------------------------------------

c       Solves Matrix equation A X = B for X using SVD method
c       Allows supression of weights, storage and recall of answers
c       Uses svd routines from numerical recipes
c       Prashant Valanju (Sept 1998) pvalanju@mail.utexas.edu

c       Almost same as SvdSolveB except this one stores U, w, V
c       rather than basis vectots.
c       Use this one when you want to change both B and weights for fixed A

c       Inputs:
c       A(M,N) - Matrix with physical dimensions (Mp,Np)
c       B(N)   - R.H.S. of A X = B
c       M      - Number of rows of A to use
c       N      - Number of columns of A to use
c       Mp,NP  - Storage dimensions of A(Mp,Np)
c       Wcut   - Cutoff parameter
c                If Wcut = 0, writes answers into "file", all weights are kept
c                If Wcut < 0, reads previous answers from "file",
c                              and uses -Wcut for weights to keep
c                If 0 < Wcut < 1 : Cuts off weights with w(i)/wmax < wcut
c                      Use this to cut off small weights, does calculation
c                If Wcut = integer > 1, keeps Wcut weights, does calculation
c                      Use this to cut off fixed number of weights
c       Output:
c       X(N)   - Solution of A X = B
c
      n1 = n

c     allocate local arrays
      allocate (u(mp,np), w(np), v(np,np), stat=istat)
      if (istat .eq. 0) then                       !have enough memory
         iunit = 41

         x(:n1) = zero                    !zero answer from previous call
         wcuta = abs(wcut)
c...............................
c     If Wcut < 0 use precalculated weights to get answer fast
c        use wcuta = abs(wcut) for everything
c     If any error happens while reading "file", do full svd calculation
         if (wcut .lt. 0) then         !Read file from previous calculation
            call safe_open(iunit, istat, file, 'old', 'formatted')
            if (istat .ne. 0) goto 98
            read (iunit, *, err=98)
            read (iunit, *, err=98)
            read (iunit, *, err=98) m, n, nonzero
            do i = 1, n     !Read exactly the same way they were written
               read (iunit, *, err=98) w(i)         !read i-th weight
               do j = 1, n
                  read (iunit, *, err=98) v(j,i)
               end do
               do j = 1, m
                  read (iunit, *, err=98) u(j,i)
               end do
            end do
            close(unit=iunit)

            go to 99                !Use U, w, V matrices to calculate X
         endif                     !End of precalculated branch Wcut < 0
   98    continue
c.......................................
c     If Wcut .ge. 0, do full svd calculation
c     Initialize all to zero to wipe out effects of old call
         do j = 1, n
            w(j) = zero                           !Zero all weights
            u(:m,j) = a(:m,j)  !Because U will be changed by svdcmp
            v(:m,j) = zero
         end do

         call svdcmp (u, m, n, mp, np, w, v)     !Do SVD decomposition

c       Sort weights and matrices with DECREASING weights
c       Permute weight w(i) AND column vectors U(*,i), V(*,i) at the same time
         call sortsvd (m, n, mp, np, w, u, v)

c       Find the number of nonzero weights (already dcreasing ordered)
         do nonzero = n, 1, -1
c                                   !Found first nonzero weight, get out
            if (w(nonzero) .ne. 0) exit
         end do
         if (nonzero .le. 0) go to 999

c............................................
c        Decide how many weights to keep
   99    continue
         if (wcuta .gt. 1) then
            nlast = wcuta
         else                                    !cutoff small weights
            wmax = w(1)                     !weights are already ordered
            nlast = 0
            do i = 1, nonzero
               if (w(i) .gt. wmax*wcuta) then
                  nlast = nlast + 1              !accept this weight
               else
                  go to 96
               endif
            end do
         endif

c       Find solution X and basis vectors (put into columns of V)
   96    continue
         if (nlast.le.0 .or. nlast.gt.nonzero) nlast = nonzero
         do i = 1, nlast     !Calc i-th coeff (U.b/w) for noNonzero w(i)
c        First calculate i-th coeff (U(i)*b/w(i)) in the sum in eq 14.3.17 (NR)
c                            !Dot product of i-th column of U with B
c                            !summed over all plasma points
            udotb = sum(u(:m,i)*b(:m))
c                        !=(Ui.b/wi) in eq 14.3.17, saves many divisions
            udotb = udotb/w(i)
c         Now run down the i-th column of the vector V(j,i)
c                         !j-th entry (row) of vectors in eq 14.3.17
c                         !add it to the j-th entry of X
            x(:n) = x(:n) + udotb*v(:n,i)
c                                  !This did the svdbksb, faster than NR
         end do                   !and also calculated the basis vectors

c............................................
c       Write all weights and U, V into SVD file (if Wcut=0)
         if (wcut .eq. 0) then
            call safe_open(iunit, istat, file, 'unknown', 'formatted')
            write (iunit, *) 'Max w = ', w(1), ', Min w = ', w(nonzero)
            write (iunit, *) 'Ratio = ', w(1)/w(nonzero)
            write (iunit, *) m, n, nonzero
            do i = 1, n
               write (iunit, *) w(i)                !write i-th weight
               do j = 1, n
                  write (iunit, *) v(j,i)
               end do
               do j = 1, m
                  write (iunit, *) u(j,i)
               end do
            end do
            close(unit=iunit)
         endif
c................................................
      endif
  999 continue

      deallocate (u, w, v, stat=istat)

!     end subroutine svdsolveuv
      end

      subroutine svdinv(m, a, wcut, file)
      use kind_spec
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer m
      real(rprec) wcut
      character file*(*)
      real(rprec), dimension(m,m) :: a
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      real(rprec) :: zero = 0
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: nonzero, nlast, istat, i, j, k, iunit
      real(rprec), allocatable :: u(:,:), w(:), v(:,:)
      real(rprec) :: wmax, wmin, wcuta, udotb, err
C-----------------------------------------------

c       Inverts Square Matrix A using SVD method
c       Allows supression of weights, storage and recall of answers
c       Uses svd routines from numerical recipes
c       Prashant Valanju (Sept 1998) pvalanju@mail.utexas.edu

c       A(M,M) - Matrix on input, Inverse on output
c       M      - Size of A
c       Wcut   - Cutoff parameter
c                If Wcut = 0, writes answers into "file", all weights are kept
c                If Wcut < 0, reads previous answers from "file",
c                              and uses -Wcut for weights to keep
c                If 0 < Wcut < 1 : Cuts off weights with w(i)/wmax < wcut
c                      Use this to cut off small weights, does calculation
c                If Wcut = integer > 1, keeps Wcut weights, does calculation
c                      Use this to cut off fixed number of weights
c
c       Note: M is same as N, Mp, and Np in this routine

c     allocate local arrays
      allocate (u(m,m), w(m), v(m,m), stat=istat)
      if (istat .eq. 0) then                       !have enough memory

         iunit = 41
         wcuta = abs(wcut)
c...............................
c     If Wcut < 0 use precalculated weights to get answer fast
c        use wcuta = abs(wcut) for everything
c     If any error happens while reading "file", do full svd calculation
         if (wcut .lt. 0) then         !Read file from previous calculation
            call safe_open(iunit, istat, file, 'old', 'formatted')
            if (istat .ne. 0) goto 98
            read (iunit, *, err=98)
            read (iunit, *, err=98)
            read (iunit, *, err=98) m, nonzero
c                           !Read exactly the same way they were written
            do i = 1, nonzero
               read (iunit, *, err=98) w(i)         !read i-th weight
               do j = 1, m
                  read (iunit, *, err=98) v(j,i), u(j,i)
               end do
            end do
            close(unit=iunit)

c        Decide how many weights to keep
            nlast = wcuta                        !remember Wcut is < 0
            nlast = min(nonzero,nlast)      !Do not use nonzero weights

            go to 99           !bypass svdcmp and go to matrix inversion
         endif               !End of precalculated U,w,V branch Wcut < 0
   98    continue
c.......................................
c     If Wcut .ge. 0, do full svd calculation and save V,w,U
c     Initialize all to zero to wipe out effects of old call
         do j = 1, m
            w(j) = zero                           !Zero all weights
            u(:m,j) = a(:m,j)  !Because U will be changed by svdcmp
            v(:m,j) = zero
         end do

         call svdcmp (u, m, m, m, m, w, v)       !Do SVD decomposition

c       Sort weights and matrices with DECREASING weights
c       Permute weight w(i) AND column vectors U(*,i), V(*,i) at the same time
         call sortsvd (m, m, m, m, w, u, v)

c       Find the number of nonzero weights (already dcreasing ordered)
         do nonzero = m, 1, -1
c                                   !Found first nonzero weight, get out
            if (w(nonzero) .ne. 0) exit
         end do
         if (nonzero .le. 0) go to 999

c       Write all weights and U, V into SVD file (if Wcut=0)
         if (wcut .eq. 0) then    !no nonzero weights, you must be kidding
            call safe_open(iunit, istat, file, 'unknown', 'formatted')
            write (iunit, *) 'Max w = ', w(1), ', Min w = ', w(nonzero)
            write (iunit, *) 'Ratio = ', w(1)/w(nonzero)
            write (iunit, *) m, nonzero
c                          !write exactly the same way they were written
            do i = 1, nonzero
               write (iunit, *) w(i)                !write i-th weight
               do j = 1, m
                  write (iunit, *) v(j,i), u(j,i)
               end do
            end do
            close(unit=iunit)
         endif
c.......................................

c       Following gets done in both cases (using saved or recalculating)
c        Decide how many weights to keep
   99    continue
         if (wcuta .gt. 1) then
            nlast = wcuta
         else                                    !cutoff small weights
            wmax = w(1)                     !weights are already ordered
            nlast = 0
            do i = 1, nonzero
               if (w(i) .gt. wmax*wcuta) then
                  nlast = nlast + 1              !accept this weight
               else
                  go to 96
               endif
            end do
         endif

c       Find Inverse of A = V [diag(1/wi)] Utranspose, return in A
c       First do [diag(1/wi)] Utranspose, store answer in U again
   96    continue
         if (nlast.le.0 .or. nlast.gt.nonzero) nlast = nonzero
         do i = 1, nlast
c                                         !divide ith row of Utr by w(i)
            u(:m,i) = u(:m,i)/w(i)
         end do
c        Zero the infinite 1/weights
         do i = nlast + 1, m
            u(:m,i) = zero                !multiply ith row of Utr by zero
         end do
c       Next multiply by V matrix to get A inverse, put it in A
         do i = 1, m                    !multiplt ith row vector of V by
            do j = 1, m                         !jth column vector of wU
                                                !vector multiply V and wU
               a(i,j) = sum(v(i,:m)*u(j,:m))    !Put inverse back in A
            end do
         end do
c................................................
      endif
  999 continue

      deallocate (u, w, v, stat=istat)

!     end subroutine svdinv
      end

      SUBROUTINE SVDCMP(A, M, N, MP, NP, W, V)
      use kind_spec
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER M, N, MP, NP
      REAL(rprec), DIMENSION(MP,NP) :: A
      REAL(rprec), DIMENSION(NP) :: W
      REAL(rprec), DIMENSION(NP,NP) :: V
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      real(rprec) :: zero = 0, one = 1, two = 2
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: I, L, K, J, ITS, NM
      REAL(rprec), DIMENSION(MP*NP) :: RV1
      REAL(rprec) :: G, SCALE, ANORM, S, F, H, C, Y, Z, X
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      REAL(rprec) , EXTERNAL :: PYTHAG
C-----------------------------------------------
      IF (M .GT. MP) STOP 'M > MP IN SVDCMP'
      IF (N .GT. NP) STOP 'N > NP IN SVDCMP'

      G = zero
      SCALE = zero
      ANORM = zero
      DO I = 1, N
         L = I + 1
         RV1(I) = SCALE*G
         G = zero
         S = zero
         SCALE = zero
         IF (I .le. M) THEN
            SCALE = SUM(ABS(A(I:M,I)))
            IF (SCALE .ne. zero) THEN
               A(I:M,I) = A(I:M,I)/SCALE
               S = SUM(A(I:M,I)*A(I:M,I))
               F = A(I,I)
               G = -SIGN(SQRT(S),F)
               H = F*G - S
               A(I,I) = F - G
               IF (I .ne. N) THEN
                  DO J = L, N
                     S = SUM(A(I:M,I)*A(I:M,J))
                     F = S/H
                     A(I:M,J) = A(I:M,J) + F*A(I:M,I)
                  END DO
               ENDIF
               A(I:M,I) = SCALE*A(I:M,I)
            ENDIF
         ENDIF
         W(I) = SCALE*G
         G = zero
         S = zero
         SCALE = zero
         IF (I.le.M .AND. I.ne.N) THEN
            SCALE = SUM(ABS(A(I,L:N)))
            IF (SCALE .ne. zero) THEN
               A(I,L:N) = A(I,L:N)/SCALE
               S = SUM(A(I,L:N)*A(I,L:N))
               F = A(I,L)
               G = -SIGN(SQRT(S),F)
               H = F*G - S
               A(I,L) = F - G
               RV1(L:N) = A(I,L:N)/H
               IF (I .ne. M) THEN
                  DO J = L, M
                     S = SUM(A(J,L:N)*A(I,L:N))
                     A(J,L:N) = A(J,L:N) + S*RV1(L:N)
                  END DO
               ENDIF
               A(I,L:N) = SCALE*A(I,L:N)
            ENDIF
         ENDIF
         ANORM = MAX(ANORM,ABS(W(I))+ABS(RV1(I)))
      END DO
      DO I = N, 1, -1
         IF (I .lt. N) THEN
            IF (G .ne. zero) THEN
               V(L:N,I) = (A(I,L:N)/A(I,L))/G
               DO J = L, N
                  S = SUM(A(I,L:N)*V(L:N,J))
                  V(L:N,J) = V(L:N,J) + S*V(L:N,I)
               END DO
            ENDIF
            V(I,L:N) = zero
            V(L:N,I) = zero
         ENDIF
         V(I,I) = one
         G = RV1(I)
         L = I
      END DO
      DO I = N, 1, -1
         L = I + 1
         G = W(I)
         IF (I .lt. N) THEN
            A(I,L:N) = zero
         ENDIF
         IF (G .ne. zero) THEN
            G = one/G
            IF (I .ne. N) THEN
               DO J = L, N
                  S = SUM(A(L:M,I)*A(L:M,J))
                  F = (S/A(I,I))*G
                  A(I:M,J) = A(I:M,J) + F*A(I:M,I)
               END DO
            ENDIF
            A(I:M,I) = A(I:M,I)*G
         ELSE
            A(I:M,I) = zero
         ENDIF
         A(I,I) = A(I,I) + one
      END DO
      L49: DO K = N, 1, -1
         DO ITS = 1, 50
            DO L = K, 1, -1
               NM = L - 1
               IF (ABS(RV1(L)) + ANORM .eq. ANORM) GO TO 2
               IF (ABS(W(NM)) + ANORM .eq. ANORM) EXIT
            END DO
            C = zero
            S = one
            DO I = L, K
               F = S*RV1(I)
               IF (ABS(F) + ANORM .ne. ANORM) THEN
                  G = W(I)
                  H = PYTHAG(F,G)
c              H=SQRT(F*F+G*G)
                  W(I) = H
                  H = one/H
                  C = G*H
                  S = -F*H
                  DO J = 1, M
                     Y = A(J,NM)
                     Z = A(J,I)
                     A(J,NM) = Y*C + Z*S
                     A(J,I) = (-Y*S) + Z*C
                  END DO
               ENDIF
            END DO
    2       CONTINUE
            Z = W(K)
            IF (L .eq. K) THEN
               IF (Z .lt. zero) THEN
                  W(K) = -Z
                  V(:N,K) = -V(:N,K)
               ENDIF
               CYCLE  L49
            ENDIF
            IF (ITS .eq. 50) THEN
               WRITE (*, '(2A)') 'PAUSE ',
     1            'No convergence in 150 iterations'
               READ *
            ENDIF
            X = W(L)
            NM = K - 1
            Y = W(NM)
            G = RV1(NM)
            H = RV1(K)
            F = ((Y - Z)*(Y + Z) + (G - H)*(G + H))/(TWO*H*Y)
            G = PYTHAG(F,one)
c          G=SQRT(F*F + one)
            F = ((X - Z)*(X + Z) + H*(Y/(F + SIGN(G,F)) - H))/X
            C = one
            S = one
            DO J = L, NM
               I = J + 1
               G = RV1(I)
               Y = W(I)
               H = S*G
               G = C*G
               Z = PYTHAG(F,H)
c            Z=SQRT(F*F+H*H)
               RV1(J) = Z
               C = F/Z
               S = H/Z
               F = X*C + G*S
               G = (-X*S) + G*C
               H = Y*S
               Y = Y*C
               DO NM = 1, N
                  X = V(NM,J)
                  Z = V(NM,I)
                  V(NM,J) = X*C + Z*S
                  V(NM,I) = (-X*S) + Z*C
               END DO
               Z = PYTHAG(F,H)
c            Z=SQRT(F*F+H*H)
               W(J) = Z
               IF (Z .ne. zero) THEN
                  Z = one/Z
                  C = F*Z
                  S = H*Z
               ENDIF
               F = C*G + S*Y
               X = (-S*G) + C*Y
               DO NM = 1, M
                  Y = A(NM,J)
                  Z = A(NM,I)
                  A(NM,J) = Y*C + Z*S
                  A(NM,I) = (-Y*S) + Z*C
               END DO
            END DO
            RV1(L) = zero
            RV1(K) = F
            W(K) = X
         END DO
      END DO L49

!     END SUBROUTINE SVDCMP
      END

      SUBROUTINE SVBKSB(U, W, V, M, N, MP, NP, B, X)
      use kind_spec
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER M, N, MP, NP
      REAL(rprec), DIMENSION(MP,NP) :: U
      REAL(rprec), DIMENSION(NP) :: W
      REAL(rprec), DIMENSION(NP,NP) :: V
      REAL(rprec), DIMENSION(MP) :: B
      REAL(rprec), DIMENSION(NP) :: X
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      real(rprec) :: zero = 0
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: J, I, JJ
      REAL(rprec), DIMENSION(MP*NP) :: TMP
      REAL(rprec) :: S
C-----------------------------------------------
      IF (M .GT. MP) STOP 'M > MP IN SVBKSB'
      IF (N .GT. NP) STOP 'N > NP IN SVBKSB'

      DO J = 1, N
         S = zero
         IF (W(J) .ne. zero) THEN
            S = SUM(U(:M,J)*B(:M))
            S = S/W(J)
         ENDIF
         TMP(J) = S
      END DO
      DO J = 1, N
         S = SUM(V(J,:N)*TMP(:N))
         X(J) = S
      END DO

!     END SUBROUTINE SVBKSB
      END

      SUBROUTINE SORTSVD(M, N, MP, NP, W, U, V)
c------------------------------
c     Sorts the weights and U, V matrices from SVD decomposition
c     Sorts weights in DECREASING order
c     Based on routine SORT2 from Numerical Recipes, pg 231
c     Created by Prashant Valanju, (Sept 1998)
c------------------------------
      use kind_spec
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER M, N, MP, NP
      REAL(rprec), DIMENSION(NP) :: W
      REAL(rprec), DIMENSION(MP,NP) :: U
      REAL(rprec), DIMENSION(NP,NP) :: V
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: L, IR, II, I, J
      REAL(rprec), DIMENSION(MP) :: RU
      REAL(rprec), DIMENSION(NP) :: RV
      REAL(rprec) :: RW
C-----------------------------------------------
      IF (M .GT. MP) STOP 'M > MP IN SORTSVD'
      IF (N .GT. NP) STOP 'N > NP IN SORTSVD'

      L = N/2 + 1
      IR = N
   10 CONTINUE
      IF (L .gt. 1) THEN
         L = L - 1
         RW = W(L)
         RU(:M) = U(:M,L)
         RV(:N) = V(:N,L)
      ELSE
         RW = W(IR)
         RU(:M) = U(:M,IR)
         RV(:N) = V(:N,IR)
         W(IR) = W(1)
         U(:M,IR) = U(:M,1)
         V(:N,IR) = V(:N,1)
         IR = IR - 1
         IF (IR .eq. 1) THEN
            W(1) = RW
            U(:M,1) = RU(:M)
            V(:N,1) = RV(:N)
            RETURN
         ENDIF
      ENDIF
      I = L
      J = L + L
   20 CONTINUE
      IF (J .le. IR) THEN
         IF (J .lt. IR) THEN
C                                    !Just change these 2 for increasing
            IF (W(J) .gt. W(J+1)) J = J + 1
         ENDIF
         IF (RW .gt. W(J)) THEN         !Just change these 2 for increasing
            W(I) = W(J)
            U(:M,I) = U(:M,J)
            V(:N,I) = V(:N,J)
            I = J
            J = J + J
         ELSE
            J = IR + 1
         ENDIF
         GO TO 20
      ENDIF
      W(I) = RW
      U(:M,I) = RU(:M)
      V(:N,I) = RV(:N)
      GO TO 10

!     END SUBROUTINE SORTSVD
      END

      function pythag (a, b)
      use kind_spec
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      real(rprec) a, b
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      real(rprec) :: zero = 0, one = 1
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      real(rprec) :: absa, absb, pythag
C-----------------------------------------------
c computes sqrt(a^2+b^2) without destructive underflow or overflow
      absa = abs(a)
      absb = abs(b)
      if (absa .gt. absb) then
         pythag = absa*sqrt(one + (absb/absa)**2)
      else
         if (absb .eq. zero) then
            pythag = zero
         else
            pythag = absb*sqrt(one + (absa/absb)**2)
         endif
      endif

!     end function pythag
      end


      FUNCTION bessy0(x)
      REAL bessy0,x
CU    USES bessj0
      REAL xx,z,bessj0
      DOUBLE PRECISION p1,p2,p3,p4,p5,q1,q2,q3,q4,q5,r1,r2,r3,r4,r5,r6,
     *s1,s2,s3,s4,s5,s6,y
      SAVE p1,p2,p3,p4,p5,q1,q2,q3,q4,q5,r1,r2,r3,r4,r5,r6,s1,s2,s3,s4,
     *s5,s6
      DATA p1,p2,p3,p4,p5/1.d0,-.1098628627d-2,.2734510407d-4,
     *-.2073370639d-5,.2093887211d-6/, q1,q2,q3,q4,q5/-.1562499995d-1,
     *.1430488765d-3,-.6911147651d-5,.7621095161d-6,-.934945152d-7/
      DATA r1,r2,r3,r4,r5,r6/-2957821389.d0,7062834065.d0,
     *-512359803.6d0,10879881.29d0,-86327.92757d0,228.4622733d0/,s1,s2,
     *s3,s4,s5,s6/40076544269.d0,745249964.8d0,7189466.438d0,
     *47447.26470d0,226.1030244d0,1.d0/
      if(x.lt.8.)then
        y=x**2
        bessy0=(r1+y*(r2+y*(r3+y*(r4+y*(r5+y*r6)))))/(s1+y*(s2+y*(s3+y*
     *(s4+y*(s5+y*s6)))))+.636619772*bessj0(x)*log(x)
      else
        z=8./x
        y=z**2
        xx=x-.785398164
        bessy0=sqrt(.636619772/x)*(sin(xx)*(p1+y*(p2+y*(p3+y*(p4+y*
     *p5))))+z*cos(xx)*(q1+y*(q2+y*(q3+y*(q4+y*q5)))))
      endif
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/bessy0.for


   ! NOTE: This MODULE is virtually a copy of MODULE FFT_Module() from TurbSim.
   !       A few unused things have been eliminated (indicated by "!remove")
   !       and a little bit of code has been added where noted (indicated by
   !       "NEW").
   ! BJJ: 02/22/2008: Updated to work with NWTC_Library v1.01.09
   !      all Abort() functions changed to ProgAbort()
!=======================================================================
MODULE FFT_Module
!-----------------------------------------------------------------------
! DESCRIPTION OF THE INVERSE FOURIER TRANSFORM ROUTINE:
!
! Given an array, H, of N complex numbers, calculate an array, h, of N real
! numbers:
!     h(J) = the sum from K=1,...,N of [ H(K)*exp(i*(J-1)*(K-1)*2*pi/N) ]
!     for J = 1,...,N
!
! where:
!     i=sqrt(-1)
!
! In order for h to be real, the real components of H must be an even function
! of frequency and the imaginary components of H must be an odd function of
! frequency.  Thus, only the first N/2 + 1 values of H are unique.  (The first
! N/2 + 1 are the positive frequencies including zero; the last N/2 - 1 values
! are the negative frequencies.)
!
! We accomplish this by defining a real array, R, where:
!     R(1) = REAL( H(1) ),
!     R(2) = REAL( H(2) ), R(3) = IMAG( H(2) ),
!     R(4) = REAL( H(3) ), R(5) = IMAG( H(3) ),...
!     R(N) = REAL( H(N/2 + 1) ).
! Note that the values of IMAG( H(1) ) and IMAG( H(N/2 + 1) ) must be zero for
! the result to be real, else the routine will abort.
!
! We return the array, r = h, of real numbers as calculated by:
!     h(J) = r(J) = R(1) + (-1)**(J-1)*R(N)
!                 + the sum from K=2,...,N/2 of
!                   [  2*R(2*K-2)*COS((K-1)*(J-1)*2*PI/N)
!                     -2*R(2*K-1)*SIN((K-1)*(J-1)*2*PI/N) ]
!     for J = 1,...,N, where N is an even number
!
! The routine is most effecient when N is a product of small primes.
!
! If the Normalization flag is set to "TRUE" in the initialization, we
! normalize the result by 1/N.
!------------------------------------------------------------------------
! DESCRIPTION OF THE COSINE TRANSFORM ROUTINE:
!
! Given an array, X, of N real numbers, calculate an array, x, of N real
! numbers:
!     x(J) = X(1) + (-1)**(J-1)*X(N)
!          + the sum from K=2,...,N-1 of [ 2*X(K)*COS((K-1)*(J-1)*PI/(N-1)) ]
!     for J = 1,...,N, where N is an odd number
!
! The routine is most effecient when N-1 is a product of small primes.
!
! If the Normalization flag is set to "TRUE" in the initialization, we
! normalize the result by 1/(N-1).
!------------------------------------------------------------------------
! DESCRIPTION OF THE SINE TRANSFORM ROUTINE:
!
! Given an array, X, of N real numbers, calculate an array, x, of N real
! numbers:
!     x(1) = X(1) = 0
!     x(J) = the sum from K=2,...,N-1 of [ 2*X(K)*SIN((K-1)*(J-1)*PI/(N-1)) ]
!     for J = 2,...,N-1, where N is an odd number
!     x(N) = X(N) = 0
!
! Note that the values of X(1) and X(N) must be zero, else the routine will
! abort.
!
! The routine is most effecient when N-1 is a product of small primes.
!
! If the Normalization flag is set to "TRUE" in the initialization, we
! normalize the result by 1/(N-1).
!------------------------------------------------------------------------

!remove   ! This module is NEW:
!remove    USE                                       Precision
! We need the Precision module and the Abort() and
! Int2LStr() functions from the NWTC_IO module.

     USE                                  NWTC_Library

IMPLICIT                                  NONE

REAL(ReKi),              PRIVATE, SAVE :: InvN             ! Normization constant
REAL(ReKi), ALLOCATABLE, PRIVATE, SAVE :: wSave(:)         ! Working array for performing transforms

INTEGER,                 PRIVATE, SAVE :: N                ! Number of steps

LOGICAL,                 PRIVATE, SAVE :: Normalize        ! Whether or not to normalize

!------------------------------------------------------------------------
CONTAINS

   SUBROUTINE ApplyCOST( TRH )
         ! Perform cosine transform.

      IMPLICIT                         NONE

      REAL(ReKi), INTENT(INOUT)     :: TRH(:)

        ! Make sure the array isn't too small

      IF ( SIZE(TRH) < N )  &
          CALL ProgAbort( 'Error in call to cosine transform.  Array size is not large enough.' )

        ! Perform the cosine transform with a FFTpack routine

      CALL COST(N, TRH, wSave) ! FFTpack routine

      IF (Normalize) THEN
          TRH(1:N) = InvN * TRH(1:N)
      ENDIF

   END SUBROUTINE ApplyCOST
  !------------------------------------------------------------------------
   SUBROUTINE ApplyFFT( TRH )
         ! Perform Backward FFT: given TRH, a REAL array representing complex numbers,
         ! return an array TRH, of real numbers.
         !     CALL FOURTH ( TRH, NumSteps, 1, WorkT, NumSteps+2 ) ! Sandia

      IMPLICIT                         NONE

      REAL(ReKi), INTENT(INOUT)     :: TRH(:)

        ! Make sure the array isn't too small

      IF ( SIZE(TRH) < N )  &
          CALL ProgAbort( 'Error in call to FFT.  Array size is not large enough.' )

        ! Perform the FFT with a FFTpack routine

      CALL RFFTB(N, TRH, wSave) ! FFTpack routine

      IF (Normalize) THEN
          TRH(1:N) = InvN * TRH(1:N)
      ENDIF

   END SUBROUTINE ApplyFFT
  !------------------------------------------------------------------------
   SUBROUTINE ApplyFFT_cx( TRH, TRH_complex )
         ! Perform Backward FFT: given TRH, a REAL array representing complex numbers,
         ! return an array TRH, of real numbers.

      IMPLICIT                         NONE

      REAL(ReKi),    INTENT(OUT)    :: TRH(:)
      COMPLEX(ReKi), INTENT(IN)     :: TRH_complex(:)

      INTEGER                       :: I
      INTEGER                       :: Indx

        ! Make sure the arrays aren't too small

      IF ( ( SIZE(TRH) < N ) .OR. ( SIZE(TRH_complex) < ( N/2 + 1 ) ) )  &
          CALL ProgAbort( 'Error in call to FFT.  Array size is not large enough.' )

        ! Make sure that the imaginary components at the zeroeth and largest
        ! positive frequency are zero, else abort.

      IF ( AIMAG( TRH_complex(1    ) ) /= 0.0 )  &
          CALL ProgAbort( 'Error in call to FFT.  The imaginary component at the zeroeth frequency must be zero.' )
      IF ( AIMAG( TRH_complex(N/2+1) ) /= 0.0 )  &
          CALL ProgAbort( 'Error in call to FFT.  The imaginary component at the largest positive frequency must be zero.' )

        ! Initialize the TRH array with Complex numbers

      TRH(1) = REAL( TRH_complex(1    ) )

      Indx = 1
      DO I=2,N-2, 2
        Indx     = Indx + 1  ! I/2 + 1

        TRH(I)   =  REAL( TRH_complex(Indx) )
        TRH(I+1) = AIMAG( TRH_complex(Indx) )
      ENDDO

      TRH(N) = REAL( TRH_complex(N/2+1) )

        ! Perform the FFT with a FFTpack routine

      CALL RFFTB(N, TRH, wSave)

      IF (Normalize) THEN
          TRH(1:N) = InvN * TRH(1:N)
      ENDIF

   END SUBROUTINE ApplyFFT_cx
  !------------------------------------------------------------------------
   SUBROUTINE ApplySINT( TRH )
         ! Perform sine transform.

      IMPLICIT                         NONE

      REAL(ReKi), INTENT(INOUT)     :: TRH(:)

        ! Make sure the array isn't too small

      IF ( SIZE(TRH) < N )  &
          CALL ProgAbort( 'Error in call to sine transform.  Array size is not large enough.' )

        ! Make sure that the value at the zeroeth and largest positive
        ! frequency are zero, else abort.

      IF ( TRH(1) /= 0.0 )  &
          CALL ProgAbort( 'Error in call to FFT.  The value at the zeroeth frequency must be zero.' )
      IF ( TRH(N) /= 0.0 )  &
          CALL ProgAbort( 'Error in call to FFT.  The value at the largest positive frequency must be zero.' )

        ! Perform the sine transform with a FFTpack routine

      CALL SINT(N-2, TRH(2:N-1), wSave) ! FFTpack routine

      IF (Normalize) THEN
          TRH(1:N) = InvN * TRH(1:N)
      ENDIF

   END SUBROUTINE ApplySINT
  !------------------------------------------------------------------------
   SUBROUTINE ExitCOST

        ! This subroutine cleans up the cosine transform working space

      IF ( ALLOCATED (wSave)    ) DEALLOCATE( wSave )

   END SUBROUTINE ExitCOST
  !------------------------------------------------------------------------
   SUBROUTINE ExitFFT

        ! This subroutine cleans up the backward FFT working space

      IF ( ALLOCATED (wSave)    ) DEALLOCATE( wSave )

   END SUBROUTINE ExitFFT
  !------------------------------------------------------------------------
   SUBROUTINE ExitSINT

        ! This subroutine cleans up the sine transform working space

      IF ( ALLOCATED (wSave)    ) DEALLOCATE( wSave )

   END SUBROUTINE ExitSINT
  !------------------------------------------------------------------------
   SUBROUTINE InitCOST( NumSteps, NormalizeIn )

        ! This subroutine initializes the cosine transform working space

      IMPLICIT                         NONE

      INTEGER, INTENT(IN)           :: NumSteps       ! Number of steps in the array
      INTEGER                       :: Sttus          ! Array allocation status

      LOGICAL, INTENT(IN), OPTIONAL :: NormalizeIn    ! Whether or not to normalize

        ! Number of timesteps in the time series returned from the cosine transform
        ! N should be odd:

      N  = NumSteps

      IF ( MOD(N,2) /= 1 ) THEN
         CALL ProgAbort ( 'The number of steps in the cosine transform must be odd' )
      ENDIF

        ! Determine if we should normalize the cosine transform:

      IF ( PRESENT( NormalizeIn ) ) THEN
          Normalize = NormalizeIn
          InvN      = 1. / ( N - 1 )
      ELSE
          Normalize = .FALSE.
      ENDIF

        ! According to FFTPACK documentation, the working array must be at
        ! least size 3N+15

      ALLOCATE ( wSave(3*N + 15) , STAT=Sttus )

      IF ( Sttus /= 0 )  THEN
         CALL ProgAbort ( 'Error allocating memory for the cosine transform working array.' )
      ENDIF

        ! Initialize the FFTPACK working space

      CALL COSTI(N, wSave)

   END SUBROUTINE InitCOST
  !------------------------------------------------------------------------
   SUBROUTINE InitFFT( NumSteps, NormalizeIn )

        ! This subroutine initializes the backward FFT working space

      IMPLICIT                         NONE

      INTEGER, INTENT(IN)           :: NumSteps       ! Number of steps in the array
      INTEGER                       :: Sttus          ! Array allocation status

      LOGICAL, INTENT(IN), OPTIONAL :: NormalizeIn    ! Whether or not to normalize the FFT

        ! Number of timesteps in the time series returned from the backward FFT
        ! N should be even:

      N  = NumSteps

      IF ( MOD(N,2) /= 0 ) THEN
         CALL ProgAbort ( 'The number of steps in the FFT must be even' ) ! For this Real FFT
      ENDIF

        ! Determine if we should normalize the FFT

      IF ( PRESENT( NormalizeIn ) ) THEN
          Normalize = NormalizeIn
          InvN      = 1. / N
      ELSE
          Normalize = .FALSE.
      ENDIF

        ! According to FFTPACK documentation, the working array must be at
        ! least size 2N+15

      ALLOCATE ( wSave(2*N + 15) , STAT=Sttus )

      IF ( Sttus /= 0 )  THEN
         CALL ProgAbort ( 'Error allocating memory for the FFT working array.' )
      ENDIF

        ! Initialize the FFTPACK working space

      CALL RFFTI(N, wSave)

   END SUBROUTINE InitFFT
  !------------------------------------------------------------------------
   SUBROUTINE InitSINT( NumSteps, NormalizeIn )

        ! This subroutine initializes the sine transform working space

      IMPLICIT                         NONE

      INTEGER, INTENT(IN)           :: NumSteps       ! Number of steps in the array
      INTEGER                       :: Sttus          ! Array allocation status

      LOGICAL, INTENT(IN), OPTIONAL :: NormalizeIn    ! Whether or not to normalize

        ! Number of timesteps in the time series returned from the sine transform
        ! N should be odd:

      N  = NumSteps

      IF ( MOD(N,2) /= 1 ) THEN
         CALL ProgAbort ( 'The number of steps in the sine transform must be odd' )
      ENDIF

        ! Determine if we should normalize the sine transform:

      IF ( PRESENT( NormalizeIn ) ) THEN
          Normalize = NormalizeIn
          InvN      = 1. / ( N - 1 )
      ELSE
          Normalize = .FALSE.
      ENDIF

        ! According to FFTPACK documentation, the working array must be at
        ! least size 2.5N+15; however, our N is +2 greater than their N

      ALLOCATE ( wSave( CEILING( 2.5*(N-2) ) + 15 ) , STAT=Sttus )

      IF ( Sttus /= 0 )  THEN
         CALL ProgAbort ( 'Error allocating memory for the sine transform working array.' )
      ENDIF

        ! Initialize the FFTPACK working space

      CALL SINTI(N-2, wSave)

   END SUBROUTINE InitSINT
  !------------------------------------------------------------------------
    FUNCTION PSF ( Npsf , NumPrimes )

    ! This routine factors the number N into its primes.  If any of those
    ! prime factors is greater than the NumPrimes'th prime, a point is added to N
    ! and the new number is factored.  This process is repeated until no
    ! prime factors are greater than the NumPrimes'th prime.

    IMPLICIT                 NONE

    !Passed variables
    INTEGER, INTENT(IN)   :: Npsf                   ! Initial number we're trying to factor.
    INTEGER, INTENT(IN)   :: NumPrimes              ! Number of unique primes.
    INTEGER               :: PSF                    ! The smallest number at least as large as Npsf, that is the product of small factors when we return.

    !Other variables
    INTEGER               :: IPR                    ! A counter for the NPrime array
    INTEGER, PARAMETER    :: NFact = 9              ! The number of prime numbers (the first NFact primes)
    INTEGER               :: NP                     ! A temp variable to determine if NPr divides NTR
    INTEGER               :: NPr                    ! A small prime number
    INTEGER               :: NT                     ! A temp variable to determine if NPr divides NTR: INT( NTR / NPr )
    INTEGER               :: NTR                    ! The number we're trying to factor in each iteration
    INTEGER, PARAMETER    :: NPrime(NFact) = (/ 2, 3, 5, 7, 11, 13, 17, 19, 23 /) ! The first 9 prime numbers

    LOGICAL               :: DividesN1(NFact)       ! Does this factor divide NTR-1?

!remove   ! This variable is NEW:
!remove    CHARACTER(11), EXTERNAL :: Int2LStr             ! A function to convert an interger to a left-justified string.

    IF ( NumPrimes > NFact )  THEN
        CALL ProgAbort ( 'In the call to PSF, NumPrimes must be less than '//TRIM( Int2LStr( NFact ) )//'.' )
    ENDIF

    DividesN1(:) = .FALSE.                          ! We need to check all of the primes the first time through

    PSF = Npsf

    DO
        ! 1.0  Factor NTR into its primes.

    NTR = PSF

    DO IPR=1,NumPrimes

        IF ( DividesN1(IPR) ) THEN

                ! If P divides N-1, then P cannot divide N.

            DividesN1(IPR) = .FALSE.               ! We'll check it next time.

        ELSE

            NPr = NPrime(IPR)                      ! The small prime number we will try to find the the factorization of NTR

            DO
                NT = NTR/NPr                       ! Doing some modular arithmetic to see if
                NP = NT*NPr                        ! MOD( NTR, NPr ) == 0, i.e. if NPr divides NTR

                IF ( NP /= NTR )  EXIT             ! There aren't any more of this prime number in the factorization

                NTR = NT                           ! This is the new number we need to get factors for
                DividesN1(IPR) = .TRUE.            ! This prime number divides Npsf, so we won't check it next time (on Npsf+1).

            ENDDO

            IF ( NTR .EQ. 1 )  RETURN              ! We've found all the prime factors, so we're finished

        ENDIF !  DividesN1

    ENDDO ! IPR

        ! 2.0  There is at least one prime larger than NPrime(NumPrimes).  Add
        !      a point to NTR and factor again.

    PSF = PSF + 1

    ENDDO

    RETURN
    END FUNCTION PSF

END MODULE FFT_Module
!=======================================================================


!  *******************************************************************
!  *                                                                 *
!  *                     Real*8 Function dlsmp1                      *
!  *                                                                 *
!  *******************************************************************
!  Double Precision Version 1.31
!  Written by Gordon A. Fenton, May 13, 1996
!  Latest Update: May 9, 2001
!
!  PURPOSE  returns the covariance between two points along a 1-D simple
!           variance function process
!
!  This routine returns the covariance between two points, separated by
!  the distance T, along a process having the simple covariance function
!
!                  var*dthx^3
!	  B(T) = --------------
!                (dthx + |T|)^3
!
!  where var is the point variance, and dthx is the scale of fluctuation
!  of the process. Both parameters, var and dthx, are brought into this
!  function via the common block /dparam/.
!
!  If var < 0, then this function returns the variance of a local average
!  of the process, |var|*V(T), averaged over the distance T.
!  The random process considered has a particularly simple variance
!  function,
!
!                     dthx
!	    V(T) = ----------
!                  dthx + |T|
!
!  where `dthx' is the scale of fluctuation of the process. This function
!  returns var*V(T), where `var' is the point variance of the process.
!  For more details, see page 204 of E.H. Vanmarcke's ``Random Fields:
!  Analysis and Synthesis.''
!
!  REVISION HISTORY:
!  1.1	added lvarfn flag to end of /dparam/ common block. Set it to
!	true if the variance function is to be returned. Otherwise this
!	function returns the covariance. (May 1/00)
!  1.2	eliminated lvarfn -- now return covariances only if var < 0 (Mar 2/01)
!  1.3	reversed default - now return covariances if var > 0. (Apr 11/01)
!  1.31	revised above documentation to reflect revision 1.3 (May 9/01)
! =======================================================================
      real*8 function dlsmp1( T )
      implicit real*8 (a-h,o-z)
      common/dparam/ var, dpb, dthx, dthy, dthz
      data zero/0.d0/
      abs(x) = dabs(x)

      if( var .lt. zero ) then			! return variance function
         dlsmp1 = -var*dthx/(dthx + abs(T))
      else					! return covariance
         at = dthx + abs(T)
         if( at .eq. zero ) then
            dlsmp1 = var
         else
            bt = dthx/at
            dlsmp1 = var*bt*bt*bt
         endif
      endif

      return
      end


	program matrix
	parameter (n=100)
	real a(n,n), work(4*n)
        real gamma(n,n)
	real w(n)

	lwork = 4*n
c initialise
	do i=1,n
c diagonal element
	  a(i,i) = float(i)
 	  do j=i+1,n
c diagonal element
 	    a(i,j) = 1.0*float(i)/float(i+j)
	  enddo
	enddo

	call ssyev('V', 'U', n, a, n, w, work, lwork, info)
	print*,'info= ', info
	do i=1,10
  	  print*,w(i)
	enddo

C check eigenvector's ortho-normal
        call sgemm('T', 'N', n, n, n, 1.0, A, n, A, n, 0.0, gamma, n)
        do i=1,5
	  write(6,200) (gamma(j,i), j=1,10)
	enddo
200     format(1x,10f10.4)
	stop
	end


#include "rundeck_opts.h"

!@sum  TRACERS_O18 water isotope specific routines and functions
!@auth Gavin Schmidt

      FUNCTION FRACVL(TEMP,trname)
!@sum FRACVL Calculate vapor-->liquid equilibrium fractionation factor
!@auth Gavin Schmidt
      USE CONSTANT, only : tf
      IMPLICIT NONE
!@var TEMP  temperature (deg C)
      REAL*8, INTENT(IN) :: TEMP
      CHARACTER, INTENT(IN) :: trname*8
      INTEGER, PARAMETER :: NTSPM=4
c**** quadratic fit to Majoube (1971)
c      REAL*8, PARAMETER ::
c     *     A(NTSPM) = (/  0d0, -3.75d-7, -6.375d-6, -6.875d-6  /),
c     *     B(NTSPM) = (/  0d0,  1.025d-4, 1.2475d-3, 1.7d-3    /),
c     *     C(NTSPM) = (/  1d0,  0.9884d0, 0.9001d0 , 0.86975d0 /)
c**** exponentials
      REAL*8, PARAMETER ::
     *     A(NTSPM) = (/  0d0,  1137d0   ,  24844d0  , 46480d0  /),
     *     B(NTSPM) = (/  0d0, -0.4156d0 , -76.248d0 ,-103.87d0 /),
     *     C(NTSPM) = (/  0d0, -2.0667d-3,  52.612d-3, 0d0      /)

!@var ITR   species number of tracer
C****       1: Fresh Water 2: o18 3: Deu  4: Tritium
      INTEGER ITR
      REAL*8 FRACVL,TK
C****
      select case (trname)
      case ('Water')
        ITR=1
      case ('H2O18')
        ITR=2
      case ('HDO')
        ITR=3
      case ('HTO')   ! tritium data not yet confirmed
        ITR=4
      case default
        write(6,*) "Tracer name ",trname," not defined in FRACVL"
        call stop_model('Tracer name not defined in FRACVL',255)
      end select
C**** Quadratic fit
c      FRACVL=C(ITR) + TEMP*(B(ITR) + TEMP*A(ITR))
C**** Exponential
      TK=TEMP+TF
      FRACVL=EXP(-A(ITR)/TK**2 - B(ITR)/TK - C(ITR))
C****
      RETURN
      END FUNCTION FRACVL

      FUNCTION FRACVS(TEMP,trname)
!@sum FRACVS Calculate vapour --> solid (ice) equil. fractionation fact.
!@auth Gavin Schmidt
      USE CONSTANT, only : tf
      IMPLICIT NONE
!@var TEMP  temperature (deg C)
      REAL*8, INTENT(IN) :: TEMP
      CHARACTER, INTENT(IN) :: trname*8
      INTEGER, PARAMETER :: NTSPM=4
C**** linear fit
c      REAL*8, PARAMETER ::
c     *     A(NTSPM) = (/  0d0,  1.36d-4,   1.46d-3, 0d0/),
c     *     B(NTSPM) = (/  1d0,  0.9850d0, 0.8834d0, 0.7845d0/)
C**** exponential
      REAL*8, PARAMETER ::
     *     A(NTSPM) = (/  0d0,  0d0       , 16288d0 , 46480d0 /),
     *     B(NTSPM) = (/  0d0,  11.839d0  , 0d0     ,-103.87d0/),
     *     C(NTSPM) = (/  0d0, -0.028244d0,-0.0934d0, 0d0     /)

!@var ITR   species number of tracer
C****       1: Fresh Water 2: o18 3: Deu  4: Tritium
      INTEGER ITR
      REAL*8 FRACVS,TK
C****
      select case (trname)
      case ('Water')
        ITR=1
      case ('H2O18')
        ITR=2
      case ('HDO')
        ITR=3
      case ('HTO')   ! tritium data not yet confirmed
        ITR=4
      case default
        write(6,*) "Tracer name ",trname," not defined in FRACVS"
        call stop_model('Tracer name not defined in FRACVS',255)
      end select
C**** linear fit
c      FRACVS=B(ITR) + A(ITR)*TEMP
C**** Exponential
      TK=TEMP+TF
      FRACVS=EXP(-A(ITR)/TK**2 - B(ITR)/TK -C(ITR))
C****
      RETURN
      END FUNCTION FRACVS

      FUNCTION FRACLS(trname)
!@sum FRACLS Calculate liquid --> solid equilibrium fractionation factor
!@auth Gavin Schmidt
      IMPLICIT NONE
      CHARACTER, INTENT(IN) :: trname*8
      INTEGER, PARAMETER :: NTSPM=4
      REAL*8, PARAMETER ::
     *     A(NTSPM) = (/ 1d0, 1.0035d0, 1.0208d0,  1.04d0/)
!@var ITR   species number of tracer
C****       1: Fresh Water 2: o18 3: Deu  4: Tritium
      INTEGER ITR
      REAL*8 FRACLS
C****
      select case (trname)
      case ('Water')
        ITR=1
      case ('H2O18')
        ITR=2
      case ('HDO')
        ITR=3
      case ('HTO')
        ITR=4
      case default
        FRACLS=1.    ! no fractionation
        RETURN
      end select
      FRACLS=A(ITR)
C****
      RETURN
      END FUNCTION FRACLS

      FUNCTION FRACLK(WS,trname)
!@sum FRACLK calculates the liquid/vapor kinetic fractionation factor
!@+          from either (Merlivat and Jouzel,1972) or as a constant
!@auth Gavin Schmidt
      IMPLICIT NONE
!@var WS surface wind speed (m/s)
      REAL*8, INTENT(IN) :: WS
      CHARACTER, INTENT(IN) :: trname*8
      INTEGER, PARAMETER :: NTSPM=4
      REAL*8, PARAMETER ::
     *     A(NTSPM) = (/ 1d0, 0.994d0,  0.99472d0,  0.98944d0  /),
     *     B(NTSPM) = (/ 0d0, 0.285d-3, 0.2508d-3,  0.5016d-3  /),
     *     C(NTSPM) = (/ 0d0, 0.82d-3,  0.7216d-3,  0.14432d-2 /)
!@var ITR   species number of tracer
C****       1: Fresh Water 2: o18 3: Deu  4: Tritium
      INTEGER ITR
      REAL*8 FRACLK
C****
C**** Calculate kinetic fractionation factor:
C****
      select case (trname)
      case ('Water')
        ITR=1
      case ('H2O18')
        ITR=2
      case ('HDO')
        ITR=3
      case ('HTO')   ! tritium data not yet confirmed
        ITR=4
      case default
        write(6,*) "Tracer name ",trname," not defined in FRACLK"
        call stop_model('Tracer name not defined in FRACLK',255)
      end select
      FRACLK=A(ITR)
      IF(WS.GE.7.) FRACLK=1d0-(B(ITR)*WS+C(ITR))
C****
      RETURN
      END FUNCTION FRACLK

#ifdef TRACERS_SPECIAL_O18
      SUBROUTINE ISOEQUIL(N,TEMP,LIQU,QMV,QML,TRMV,TRML,FEQ)
!@sum ISOEQUIL equilibrates isotopes in vapor & liquid/solid reservoirs
!@auth Gavin Schmidt/Georg Hoffmann
      USE CONSTANT, only : tf
      USE TRACER_COM, only: trname,tr_wd_TYPE,nWATER
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: N
      LOGICAL, INTENT(IN) :: LIQU !@var LIQU true if QML is liquid
      REAL*8, INTENT(IN) :: TEMP  !@var TEMP temperature (K)
!@var QMV,QML vapour and liquid water masses (kg or kg/m^2)
      REAL*8, INTENT(IN) :: QMV,QML
!@var TRMV,TRML vapour and liquid tracer mass (kg or kg/m^2)
      REAL*8, INTENT(INOUT) :: TRMV,TRML
!@var FEQ fraction of condensate equilibrated (1. = all, 0. = none)
      REAL*8, INTENT(IN) :: FEQ
      REAL*8 TDEGC,ZALPH,ZDELEQU,ZXFAC,FRACVL,FRACVS

      SELECT CASE(tr_wd_TYPE(N))
      CASE(nWATER)
        TDEGC = TEMP - TF
        IF (QMV.GT.0.) THEN
          IF (LIQU) THEN
            ZALPH = 1./FRACVL(TDEGC,trname(N))
          ELSE
            ZALPH = 1./FRACVS(TDEGC,trname(N))
          END IF
          ZXFAC = FEQ*ZALPH*QML/QMV
          ZDELEQU = (FEQ*TRML - ZXFAC*TRMV)/(1.+ZXFAC)
          TRML = TRML - ZDELEQU
          TRMV = TRMV + ZDELEQU
        END IF
      END SELECT

      RETURN
C****
      END SUBROUTINE ISOEQUIL

      FUNCTION KIN_COND_ICE(ALPH,SUPSAT,trname)
!@sum calculate kinetic fractionation when condensing to ice in
!@+   super-saturated conditions
!@auth Gavin Schmidt/Georg Hoffmann
      USE CONSTANT, only : tf
      IMPLICIT NONE
      CHARACTER, INTENT(IN) :: trname*8
!@var SUPSAT super_saturation factor from cloud scheme
      REAL*8, INTENT(IN) :: SUPSAT
!@var ALPH equilibrium fractionation
      REAL*8, INTENT(IN) :: ALPH
!@var ZDIFREL = inverse ratio of diffusion coeffs w.r.t normal water
      real*8 :: ZDIFREL(4) = (/ 1d0 ,1.0285d0, 1.0251d0, 1.0331d0/)
      integer itr
      real*8 kin_cond_ice
C****
C**** Calculate kinetic condensation when condensing to ice
C****
      select case (trname)
      case ('Water')
        ITR=1
      case ('H2O18')
        ITR=2
      case ('HDO')
        ITR=3
      case ('HTO')
        ITR=4
      case default
        write(6,*) "Tracer name ",trname," not defined in KIN_COND"
        call stop_model('Tracer name not defined in KIN_COND',255)
      end select
      KIN_COND_ICE=alph*SUPSAT/(1.+(SUPSAT-1.)*alph*ZDIFREL(ITR))

      return
      end function kin_cond_ice

      FUNCTION KIN_EVAP_PREC(ALPH,HEFF,trname)
!@sum calculate kinetic fractionation when evaporating into
!@+   undersaturated environment
!@auth Gavin Schmidt/Georg Hoffmann
      USE CONSTANT, only : tf
      IMPLICIT NONE
      CHARACTER, INTENT(IN) :: trname*8
!@var HEFF effective relative humidity from cloud scheme
      REAL*8, INTENT(IN) :: HEFF
!@var alph equilibrium fractionation
      REAL*8, INTENT(IN) :: ALPH
!@var ZDIFRELGAM = ZDIFREL^0.58
      real*8 :: ZDIFRELGAM(4) = (/ 1d0, 1.0164d0, 1.0145d0, 1.0191d0/)
      integer itr
      real*8 kin_evap_prec
C****
C**** Calculate kinetic condensation when evaporating below clouds
C****
      select case (trname)
      case ('Water')
        ITR=1
      case ('H2O18')
        ITR=2
      case ('HDO')
        ITR=3
      case ('HTO')
        ITR=4
      case default
        write(6,*) "Tracer name ",trname," not defined in KIN_EVAP"
        call stop_model('Tracer name not defined in KIN_EVAP',255)
      end select
      KIN_EVAP_PREC=alph*HEFF/(1.+(HEFF-1.)*alph*ZDIFRELGAM(ITR))

      return
      end function kin_evap_prec

      FUNCTION delta(W,T,n)
!@sum calculate per mil values
      use TRACER_COM, only : trw0
      implicit none
      real*8, intent(in) :: W,T
      integer, intent(in) :: n
      real*8 delta

      delta=0.
      if (trw0(n).gt.0 .and. W.gt.0) delta=(T/(W*trw0(n))-1.)*1d3

      return
      end function delta
#endif


 ! The decimal number, 585 = 10010010012
 ! (binary), is palindromic in both bases.
 !
 ! Find the sum of all numbers, less than
 ! one million, which are palindromic in
 ! base 10 and base 2.
 !
 ! Project Euler: 36
 ! Answer: 872187

program main

        use euler

implicit none

        integer (int32), parameter :: MAX_N = 1000000;
        integer (int32) :: i, sum;

        sum = 0

        do i = 1, MAX_N
                if(intrev(i) == i .and. binrev(i) == i) sum = sum + i
        end do

        print*, sum

contains

        ! This function works the same as the base 10 one; we start with a
        ! blank integer, and read results from one end, appending to the other

        function binrev(x)

                integer (int32) :: binrev, x, n
                binrev = 0;
                n = x

                do while (n > 0)
                        binrev = IEOR(ISHFT(binrev, 1), IAND(n, 1));
                        n = ISHFT(n, -1);

                end do

        end function binrev

end program main