MODULE FUN_xyDIST
!!#### PURPOSE
!! Compute the distance objects in R^2:
!!  @ two points <PP>,
!!  @ a line and a point <LnP>.

!!#### EXTERNAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))

!!#### EXTERNAL PROCEDURES
USE FUN_xyNORM,ONLY: xyNORM_V                  !!((03-A-FUN_xyNORM.f90))
USE FUN_xyDOT ,ONLY: xyDOT_VV                  !!((03-A-FUN_xyDOT.f90))

!!#### DEFAULT IMPLICIT
IMPLICIT NONE

!!#### DEFAULT ACCESS
PRIVATE

!!#### PROCEDURE OVERLOADING
INTERFACE xyDIST_PP
 MODULE PROCEDURE xyDIST_PP_Rsp
 MODULE PROCEDURE xyDIST_PP_Rdp
ENDINTERFACE

INTERFACE xyDIST_LnP
 MODULE PROCEDURE xyDIST_LnP_Rsp
 MODULE PROCEDURE xyDIST_LnP_Rdp
ENDINTERFACE

!!#### PUBLIC ACCESS LIST
PUBLIC :: xyDIST_PP
PUBLIC :: xyDIST_LnP

CONTAINS

PURE FUNCTION xyDIST_PP_Rsp( P_a , P_b ) RESULT( DIST )
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "04-B-FUN_xyDIST_PP.f90.hdr"
!!--begin--
INCLUDE "04-B-FUN_xyDIST_PP.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyDIST_PP_Rdp( P_a , P_b ) RESULT( DIST )
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "04-B-FUN_xyDIST_PP.f90.hdr"
!!--begin--
INCLUDE "04-B-FUN_xyDIST_PP.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyDIST_LnP_Rsp( Ln , P ) RESULT( DIST )
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "04-B-FUN_xyDIST_LnP.f90.hdr"
!!--begin--
INCLUDE "04-B-FUN_xyDIST_LnP.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyDIST_LnP_Rdp( Ln , P ) RESULT( DIST )
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "04-B-FUN_xyDIST_LnP.f90.hdr"
!!--begin--
INCLUDE "04-B-FUN_xyDIST_LnP.f90.bdy"
!!--end--
END FUNCTION

END MODULE


    module test
    use custom_precision
    use comparison
    use pretty_print
    use solver_preparation
    use ascii_io

    implicit none

    private

    integer        :: info, diffcount
    real           :: maxabsdiff
    real(DP)       :: maxabsdiff_dp
    integer        :: alloc_status
    real           :: tstart, tfinish

    interface test_tridiagonal_solver
    procedure test_tridiagonal_solver_sp
    procedure test_tridiagonal_solver_dp
    end interface

    interface test_tridiagonal_solver_xp
    procedure test_tridiagonal_solver_xp_sp
    procedure test_tridiagonal_solver_xp_dp
    end interface

    interface test_poisson_solver
    procedure test_poisson_solver_sp
    end interface

    public test_tridiagonal_solver, test_tridiagonal_solver_xp, test_poisson_solver

    contains

    !#####################################################
    subroutine test_tridiagonal_solver_sp(matrix, n, rhs, sol, err)
    real(SP), allocatable, intent(in)       :: matrix(:,:)
    integer, intent(in)                     :: n
    real(SP), allocatable, intent(in)       :: rhs(:), sol(:)
    integer, intent(out)                    :: err

    real(SP), allocatable                   :: d(:), dl(:), du(:), local_sol(:)

    integer                                 :: i

    err = 0

    allocate(d(N),      &
        dl(N - 1),      &
        du(N - 1),      &
        local_sol(N),   &
        stat=alloc_status)
    if (alloc_status) then
        write(*,*) "ERROR: Failed to allocate required arrays...!"
        write(*,*) "       Try reducing the size."
        err = -100
        return
    end if

    do i = 1, n
        d(i) = matrix(i, i)
        if (i > 1) dl(i - 1) = matrix(i, i - 1)
        if (i < n) du(i) = matrix(i, i + 1)
    end do

    local_sol(:) = rhs(:)

    call cpu_time(tstart)
    write(*,*) "Solving the system in SP..."
    call sgtsv(n, 1, dl, d, du, local_sol, n, info)
    if (info == 0) then
        write(*,*) "Solution OK!"
    else
        write(*,*) "Solution failed!"
        err = info
        goto 999
    end if
    call cpu_time(tfinish)
    write(*, '("sgtsv time = ",f6.3," seconds.")') tfinish - tstart

    write(*,*) "Comparing results..."
    call compare(sol, local_sol, diffcount, maxabsdiff, 1.e-5)
    if (diffcount > 0) then
        write(*,*) "Found ", diffcount, " differences in ", N, " values!"
        write(*,*) "Max absolute difference: ", maxabsdiff
    else
        write(*,*) "Results match within tolerance!"
    end if
    call pretty_write(local_sol, 'sgtsv_out.log')

999 write(*,*) "********************"

    deallocate(d, dl, du, local_sol)
    end subroutine test_tridiagonal_solver_sp

    !#####################################################
    subroutine test_tridiagonal_solver_dp(matrix, n, rhs, sol, err)
    real(DP), allocatable, intent(in)       :: matrix(:,:)
    integer, intent(in)                     :: n
    real(DP), allocatable, intent(in)       :: rhs(:), sol(:)
    integer, intent(out)                    :: err

    real(DP), allocatable                   :: d(:), dl(:), du(:), local_sol(:)

    integer                                 :: i

    err = 0

    allocate(d(N),      &
        dl(N - 1),      &
        du(N - 1),      &
        local_sol(N),   &
        stat=alloc_status)
    if (alloc_status) then
        write(*,*) "ERROR: Failed to allocate required arrays...!"
        write(*,*) "       Try reducing the size."
        err = -100
        return
    end if

    do i = 1, n
        d(i) = matrix(i, i)
        if (i > 1) dl(i - 1) = matrix(i, i - 1)
        if (i < n) du(i) = matrix(i, i + 1)
    end do

    local_sol(:) = rhs(:)

    call cpu_time(tstart)
    write(*,*) "Solving the system in DP..."
    call dgtsv(n, 1, dl, d, du, local_sol, n, info)
    if (info == 0) then
        write(*,*) "Solution OK!"
    else
        write(*,*) "Solution failed!"
        err = info
        goto 998
    end if
    call cpu_time(tfinish)
    write(*, '("dgtsv time = ",f6.3," seconds.")') tfinish - tstart

    write(*,*) "Comparing results..."
    call compare(sol, local_sol, diffcount, maxabsdiff_dp, 1.d-5)
    if (diffcount > 0) then
        write(*,*) "Found ", diffcount, " differences in ", N, " values!"
        write(*,*) "Max absolute difference: ", maxabsdiff_dp
    else
        write(*,*) "Results match within tolerance!"
    end if
    call pretty_write(local_sol, 'dgtsv_out.log')

998 write(*,*) "********************"

    deallocate(d, dl, du, local_sol)
    end subroutine test_tridiagonal_solver_dp

    !#####################################################
    subroutine test_tridiagonal_solver_xp_sp(matrix, n, rhs, sol, err)
    real(SP), allocatable, intent(in)       :: matrix(:,:)
    integer, intent(in)                     :: n
    real(SP), allocatable, intent(in)       :: rhs(:), sol(:)
    integer, intent(out)                    :: err

    real(SP), allocatable                   :: d(:), dl(:), du(:), local_sol(:)
    real(SP), allocatable                   :: DF(:), DLF(:), DUF(:), DU2(:)
    integer, allocatable                    :: IPIV(:)
    real(SP)                                :: rcond
    real(SP)                                :: ferr(1), berr(1)
    real(SP), allocatable                   :: work(:)
    integer, allocatable                    :: iwork(:)

    integer                                 :: i

    err = 0

    allocate(d(N),      &
        dl(N - 1),      &
        du(N - 1),      &
        local_sol(N),   &
        stat=alloc_status)
    if (alloc_status) then
        write(*,*) "ERROR: Failed to allocate required arrays...!"
        write(*,*) "       Try reducing the size."
        err = -100
        return
    end if

    do i = 1, n
        d(i) = matrix(i, i)
        if (i > 1) dl(i - 1) = matrix(i, i - 1)
        if (i < n) du(i) = matrix(i, i + 1)
    end do

    local_sol(:) = rhs(:)

    allocate(DF(N),     &
        DLF(N-1),       &
        DUF(N-1),       &
        DU2(N-2),       &
        IPIV(N),        &
        work(3 * N),    &
        iwork(N),       &
        stat=alloc_status)
    if (alloc_status) then
        write(*,*) "ERROR: Failed to allocate required arrays...!"
        write(*,*) "       Try reducing the size."
        err = -100
        goto 997
    end if

    call cpu_time(tstart)
    write(*,*) "Solving the system in SP (expert mode)..."
    call sgtsvx	('N', 'N', n, 1, dl, d, du, DLF, DF, DUF, DU2, IPIV, rhs, n, &
        local_sol, n, rcond, ferr, berr, work, iwork, info)
    if (info == 0) then
        write(*,*) "Solution OK!"
    else
        write(*,*) "Solution failed!"
        err = info
        goto 996
    end if
    call cpu_time(tfinish)
    write(*, '("sgtsvx time = ",f6.3," seconds.")') tfinish - tstart
    write(*, '("Backward error = ", f12.7)') berr(1)
    write(*, '("Forward error = ", f12.7)') ferr(1)

    write(*,*) "Comparing results..."
    call compare(sol, local_sol, diffcount, maxabsdiff, 1.e-5)
    if (diffcount > 0) then
        write(*,*) "Found ", diffcount, " differences in ", N, " values!"
        write(*,*) "Max absolute difference: ", maxabsdiff
    else
        write(*,*) "Results match within tolerance!"
    end if
    call pretty_write(local_sol, 'sgtsvx_out.log')

996 deallocate(DF, DLF, DUF, DU2, IPIV, work, iwork)
997 write(*,*) "********************"

    deallocate(d, dl, du, local_sol)
    end subroutine test_tridiagonal_solver_xp_sp

    !#####################################################
    subroutine test_tridiagonal_solver_xp_dp(matrix, n, rhs, sol, err)
    real(DP), allocatable, intent(in)       :: matrix(:,:)
    integer, intent(in)                     :: n
    real(DP), allocatable, intent(in)       :: rhs(:), sol(:)
    integer, intent(out)                    :: err

    real(DP), allocatable                   :: d(:), dl(:), du(:), local_sol(:)
    real(DP), allocatable                   :: DF(:), DLF(:), DUF(:), DU2(:)
    integer, allocatable                    :: IPIV(:)
    real(DP)                                :: rcond
    real(DP)                                :: ferr(1), berr(1)
    real(DP), allocatable                   :: work(:)
    integer, allocatable                    :: iwork(:)

    integer                                 :: i

    err = 0

    allocate(d(N),      &
        dl(N - 1),      &
        du(N - 1),      &
        local_sol(N),   &
        stat=alloc_status)
    if (alloc_status) then
        write(*,*) "ERROR: Failed to allocate required arrays...!"
        write(*,*) "       Try reducing the size."
        err = -100
        return
    end if

    do i = 1, n
        d(i) = matrix(i, i)
        if (i > 1) dl(i - 1) = matrix(i, i - 1)
        if (i < n) du(i) = matrix(i, i + 1)
    end do

    local_sol(:) = rhs(:)

    allocate(DF(N),     &
        DLF(N-1),       &
        DUF(N-1),       &
        DU2(N-2),       &
        IPIV(N),        &
        work(3 * N),    &
        iwork(N),       &
        stat=alloc_status)
    if (alloc_status) then
        write(*,*) "ERROR: Failed to allocate required arrays...!"
        write(*,*) "       Try reducing the size."
        err = -100
        goto 995
    end if

    call cpu_time(tstart)
    write(*,*) "Solving the system in DP (expert mode)..."
    call dgtsvx	('N', 'N', n, 1, dl, d, du, DLF, DF, DUF, DU2, IPIV, rhs, n, &
        local_sol, n, rcond, ferr, berr, work, iwork, info)
    if (info == 0) then
        write(*,*) "Solution OK!"
    else
        write(*,*) "Solution failed!"
        err = info
        goto 994
    end if
    call cpu_time(tfinish)
    write(*, '("dgtsvx time = ",f6.3," seconds.")') tfinish - tstart
    write(*, '("Backward error = ", f12.7)') berr(1)
    write(*, '("Forward error = ", f12.7)') ferr(1)

    write(*,*) "Comparing results..."
    call compare(sol, local_sol, diffcount, maxabsdiff_dp, 1.d-5)
    if (diffcount > 0) then
        write(*,*) "Found ", diffcount, " differences in ", N, " values!"
        write(*,*) "Max absolute difference: ", maxabsdiff_dp
    else
        write(*,*) "Results match within tolerance!"
    end if
    call pretty_write(local_sol, 'dgtsvx_out.log')

994 deallocate(DF, DLF, DUF, DU2, IPIV, work, iwork)
995 write(*,*) "********************"

    deallocate(d, dl, du, local_sol)
    end subroutine test_tridiagonal_solver_xp_dp

    !#####################################################
    subroutine test_poisson_solver_sp(nrows, ncols, dx, dy)
    integer, intent(in)                 :: nrows, ncols
    real(SP), intent(in)                :: dx, dy

    integer                             :: N, irow, icol, k, npiv
    real(SP), allocatable               :: Q(:), Qold(:), coefs(:,:), grid(:,:)
    integer                             :: info, alloc_stat
    integer, allocatable                :: ipiv(:)

    N = nrows * ncols
    npiv = max(1, min(nrows, ncols))

    allocate(Q(N), stat=alloc_stat)
    if (alloc_stat /= 0) then
        write(*,*) "ERROR: during required arrays allocation Q...!"
        return
    end if

    allocate(Qold(N), stat=alloc_stat)
    if (alloc_stat /= 0) then
        write(*,*) "ERROR: during required arrays allocation Qold...!"
        return
    end if

    allocate(coefs(N,N), stat=alloc_stat)
    if (alloc_stat /= 0) then
        write(*,*) "ERROR: during required arrays allocation coefs...!"
        return
    end if

    allocate(grid(nrows, ncols), stat=alloc_stat)
    if (alloc_stat /= 0) then
        write(*,*) "ERROR: during required arrays allocation grid...!"
        return
    end if

    allocate(ipiv(npiv), stat=alloc_stat)
    if (alloc_stat /= 0) then
        write(*,*) "ERROR: during required arrays allocation ipiv...!"
        return
    end if

    Q(:) = 0.

    ! inner points
    do icol = 2, ncols - 1
        do irow = 2, nrows - 1
            k = get_linear_index(irow, icol, nrows)
            Q(k) = icol
        end do
    end do

    ! left boundary
    icol = 1
    do irow = 1, nrows
        k = get_linear_index(irow, icol, nrows)
        Q(k) = 4.0
    end do

    ! right boundary
    icol = ncols
    do irow = 2, nrows- 1
        k = get_linear_index(irow, icol, nrows)
        Q(k) = icol - 3. * 0.2 / dx
    end do

    ! top boundary
    irow = nrows
    do icol = 1, ncols
        k = get_linear_index(irow, icol, nrows)
        Q(k) = 4.0
    end do

    ! bottom boundary
    irow = 1
    do icol = 1, ncols
        k = get_linear_index(irow, icol, nrows)
        Q(k) = 4.0
    end do

    call fill_coefficient_matrix_poisson(coefs, nrows, ncols, dx, dy)
    call fill_coefficient_matrix_poisson_dirichlet_left(coefs, nrows, ncols)
    call fill_coefficient_matrix_poisson_neumann_right(coefs, nrows, ncols, dx, dy)
    call fill_coefficient_matrix_poisson_dirichlet_bottom(coefs, nrows, ncols)
    call fill_coefficient_matrix_poisson_dirichlet_top(coefs, nrows, ncols)

    call map_vector_components_to_grid(Q, N, grid, nrows, ncols)
    call export_to_ascii('before_solution.asc', nrows, ncols, grid, -9999., 0., 0., dx)

    call sgetrf(N, N, coefs, N, ipiv, info)
    if (info /= 0) then
        write(*,*) "ERROR: during coefficient matrix factorisation..."
        deallocate(Q, Qold, coefs, grid, ipiv)
        return
    end if

    call sgetrs('N', N, 1, coefs, N, ipiv, Q, N, info)
    if (info /= 0) then
        write(*,*) "ERROR: during system solution process..."
        deallocate(Q, Qold, coefs, grid, ipiv)
        return
    end if

    call map_vector_components_to_grid(Q, N, grid, nrows, ncols)
    call export_to_ascii('after_solution.asc', nrows, ncols, grid, -9999., 0., 0., dx)

    deallocate(Q, Qold, coefs, grid, ipiv)
    end subroutine test_poisson_solver_sp

    end module test


program trace

  !------------------------------------------------------------
  !-------THIS PROGRAM TRACES A CHARGED PARTICLE IN A SPECIFIED
  !-------ELECTROMAGNETIC FIELD.
  !-------
  !-------THIS CODE IS INTENDED TO BE FORTRAN 2003 COMPLIANT
  !-------
  !-------SI UNITS (KG,M,S,T,V/M,ETC.) ARE USED FOR ALL QUANTITIES.
  !-------ALL QUANTITIES ARE CARTESIAN.
  !-------
  !-------BASED ON CODE DEVELOPED BY
  !-------M. ZETTERGREN, G. GONZALEZ, AND J. HUGHES.
  !------------------------------------------------------------

  implicit none

  !CONSTANTS
  real(8), parameter :: pi=3.14159265d0
!  real(8), parameter :: q=-1.60217657d-19    !electron
  real(8), parameter :: q=1.60217657d-19    !proton
!  real(8), parameter :: m=9.109382d-31    !electron
  real(8), parameter :: m=1.672621d-27    !proton
  real(8), parameter :: cyclefrac=1d-3    !fraction of cyclotron period to use for time step 1000 works well for RK2

  !FIELDS AND PARTICLE STATE
  real(8), dimension(3) :: E,B    !3 components of electric and magnetic fields
  real(8), dimension(3) :: r,rprev,v,vprev,a   !position and veloc., current and previous values; accel.

  !TIME-RELATED VARS.
  real(8) :: Tcyc
  real(8) :: t,dt
  integer(8) :: it,lt,itout,ltout
  integer(8) :: cycles

  !RUN TIME AND OUTPUT RATE
  cycles=floor(1d0/cyclefrac)            !cycles per cyclotron period
  lt=10*cycles                           !roughly 10 cyclotron periods for total simulation time
  itout=cycles/20                        !write every 1/25 cyclotron period (so cyc motion is apparent in plots)
  ltout=lt/itout

  !SET THE INITIAL ELECTRIC AND MAGNETIC FIELDS x,y,z

  !POSITION AND VELOCITY INITIAL CONDITIONS
  rprev=[0d0, 0d0, 0d0]
  vprev=[0d0, 1000d0, 1000d0]

  !START AN OUTPUT FILE
  open(42,file='trace_output.dat',status='replace',access='stream')     !binary file output
  write(42) ltout

  !MAIN INTEGRATION LOOP
  t=0d0
  do it=1,lt
    !COMPUTE THE FIELDS
    call Efield(rprev,t,E)
    call Bfield(rprev,t,B)

    !CYLCOTRON PERIOD AND TIME STEP
    Tcyc=abs((2d0*pi*m)/(q*sqrt(B(1)**2+B(2)**2+B(3)**2)))

    !TIME STEP DETERMINATION
    dt=cyclefrac*Tcyc

    !RK2 UPDATE OF POSITION AND VELOCITY
    !first compute forces/acceleration at beginning of time step
    a(1)=(q/m)*(E(1)+B(3)*vprev(2)-B(2)*vprev(3))
    a(2)=(q/m)*(E(2)+B(1)*vprev(3)-B(3)*vprev(1))
    a(3)=(q/m)*(E(3)+B(2)*vprev(1)-B(1)*vprev(2))

    !advance the velocity and position by dt/2
    v=vprev+dt/2d0*a
    r=rprev+dt/2d0*vprev

    !recompute fields at new position and time
    call Efield(r,t+dt/2d0,E)
    call Bfield(r,t+dt/2d0,B)

    !re-evaluate forces at t+dt/2
    a(1)=(q/m)*(E(1)+B(3)*v(2)-B(2)*v(3))
    a(2)=(q/m)*(E(2)+B(1)*v(3)-B(3)*v(1))
    a(3)=(q/m)*(E(3)+B(2)*v(1)-B(1)*v(2))

    !fully update the position and velocity to t+dt
    v=vprev+dt*a
    r=rprev+dt*v
    t=t+dt

    !OUTPUT, IF REQUIRED
    if(mod(it,itout)==0) then
      write(*,*) 'The cyclotron period is:',Tcyc,' seconds'
      write(*,*) 'The time and time step are',t,dt
      write(*,*) 'Iteration number and total requested iterations ',it,lt
      write(*,*) 'Output of current state...'
      write(42) t,r,v
    endif

    !STORE PREVIOUS VALUE FOR NEXT TIME STEP
    rprev=r
    vprev=v
  enddo

  !FINISH OUTPUT FILE
  close(42)

contains

  pure subroutine Efield(r,t,E)    !avoids altering other variables.

    !------------------------------------------------------------
    !-------POPULATES THE ELECTRIC FIELD ARRAY (AS A FN. OF
    !-------TIME AND SPACE)
    !------------------------------------------------------------

    real(8), dimension(3), intent(in) :: r
    real(8), intent(in) :: t
    real(8), dimension(3), intent(inout) :: E

    E(1)=0d0
    E(2)=0d0
    E(3)=0d0

  end subroutine Efield

  pure subroutine Bfield(r,t,B)

    !------------------------------------------------------------
    !-------POPULATES THE MAGNETIC FIELD ARRAY (AS A FN. OF
    !-------TIME AND SPACE)
    !------------------------------------------------------------

    real(8), dimension(3), intent(in) :: r
    real(8), intent(in) :: t
    real(8), dimension(3), intent(inout) :: B

    B(1)=0d0
    B(2)=0d0
    B(3)=45000d-9

  end subroutine Bfield

end program trace


!---------------------------------------------------------------------!
! OWNER: Ithaca Combustion Enterprise, LLC                            !
! COPYRIGHT: © 2012, Ithaca Combustion Enterprise, LLC                !
! LICENSE: BSD 3-Clause License (The complete text of the license can !
!  be found in the `LICENSE-ICE.txt' file included in the ISAT-CK7    !
!  source directory.)                                                 !
!---------------------------------------------------------------------!

subroutine ell_house( n, x, v, beta )

!  Determine a Householder vector v based on x.
!  The orthogonal matrix P = I - beta * v * v^T has the
!  property: Px = |x| * e_1.

!  From Golub & Van Loan Algorithm 5.1.1

integer, intent(in)           :: n
real(kind(1.d0)), intent(in)  :: x(n)
real(kind(1.d0)), intent(out) :: v(n), beta

real(kind(1.d0)) :: sigma, mu

v    = 0.d0
beta = 0.d0
if( n <= 1 ) return

sigma  = sum( x(2:n)*x(2:n) )
v(1)   = 1.d0
v(2:n) = x(2:n)

if( sigma == 0.d0 ) then
   beta = 0.d0
else
   mu = sqrt( x(1)**2 + sigma )
   if( x(1) < 0.d0 ) then
      v(1) = x(1) - mu
   else
      v(1) = -sigma / ( x(1) + mu )
   endif

   beta = 2.*v(1)**2 / (sigma+v(1)**2)
   v    = v / v(1)
endif

return

end subroutine ell_house


program main
      implicit none
      integer::i,j,n=108
      real(kind=8)::pot_lj
      real(8)::v,v1,v2,f,k=0.0000001
      real(8),allocatable::a(:,:),rx(:),ry(:),rz(:)

      allocate (a(n,n),rx(n),ry(n),rz(n))

      open(1,file='argon.init')

     do  i=1,n
        read(1,*) (a(i,j),j=1,3)
        !write(10,*)(a(i,j),j=1,3)
        rx(i) =a(i,1)
        ry(i) =a(i,2)
        rz(i) =a(i,3)
     end do
     call calc_pot(n,rx,ry,rz,v)
     write(*,*)v
     rx(2)=rx(2)+k
     call calc_pot(n,rx,ry,rz,v1)
     write(*,*)v1
     rx(2)=rx(2)-(2*k)
     call calc_pot(n,rx,ry,rz,v2)
     write(*,*)v2
     f = ((v2 -v1)/(2*k))
     write(*,*)'force =',f
end program main

subroutine calc_pot(n,rx,ry,rz,pot_lj)
     implicit none
     integer ::n
     real(kind=8) :: rx (200),ry(200),rz(200)
     real(kind=8) :: pot_lj
     integer::i,j
     real(kind=8) :: boxl,sigsq,epslon
     real(kind=8) :: rxij,ryij,rzij,rijsq
     real(kind=8) :: sr2,sr6,sr12
     real(kind=8) :: rcutoffsq,rcutoff
     real(kind=8) :: sig,kb,a
     n=108
     !do i= 1,n
        !write(15,*)rx(i),ry(i),rz(i)
    !end do

      boxl =17.158d0
      sig = 3.405d0
      sigsq = sig * sig
      kb = 1.38E-23
      epslon = 120.0d0 !* kb

      rcutoff = 0.50d0 * boxl
      rcutoffsq = rcutoff * rcutoff

     do i=1,n
        rx(i) = rx(i) - (boxl * anint(rx(i)/boxl))
        ry(i) = ry(i) - (boxl * anint(ry(i)/boxl))
        rz(i) = rz(i) - (boxl * anint(rz(i)/boxl))
        !write(3,*)rx(i),ry(i),rz(i)
     end do

     pot_lj=0.0d0
     do i=1,n-1
      do j=i+1,n
           rxij = rx(i) - rx(j)
           ryij = ry(i) - ry(j)
           rzij = rz(i) - rz(j)

           rxij = rxij - (boxl * anint(rxij/boxl))
           ryij = ryij - (boxl * anint(ryij/boxl))
           rzij = rzij - (boxl * anint(rzij/boxl))
           !write(18,*)rxij,ryij,rzij

           rijsq = rxij**2 + ryij**2 + rzij**2
           !write(19,*)rijsq
           sr2 = sigsq/rijsq
           sr6 = sr2 * sr2 * sr2
           sr12 = sr6 * sr6
        if(rijsq<rcutoffsq) then
          pot_lj= pot_lj + sr12 -sr6
        endif
     end do
   end do
    pot_lj = 4.0d0*epslon*pot_lj
end subroutine calc_pot


subroutine MakeCircleCoord(coord, lat, lon, theta0, cinterval, cnum, &
                           exitstatus)
!------------------------------------------------------------------------------
!
!   This subroutine will return the latitude and longitude
!   coordinates of a circle of radius theta from a given
!   point. The first index in the output vectors corresponds
!   to the point directly north of the central cirlce coordinates,
!   and subsequent points arranged in a clockwise manner.
!
!   Calling Parameters
!
!       IN
!           lat         Latitude in degrees.
!           lon         Longitude in degrees.
!           theta0      Angular radius of the circle in degrees.
!
!       OUT
!           coord       360/interval (latitude, longitude) coordinates.
!
!       OPTIONAL, IN
!           cinterval   Angular spacing of latitude and longitude points
!                       in degrees (default=1).
!
!       OPTIONAL, OUT
!           cnum        Number of points in the output vectors.
!           exitstatus  If present, instead of executing a STOP when an error
!                       is encountered, the variable exitstatus will be
!                       returned describing the error.
!                       0 = No errors;
!                       1 = Improper dimensions of input array;
!                       2 = Improper bounds for input variable;
!                       3 = Error allocating memory;
!                       4 = File IO error.
!
!   Copyright (c) 2005-2019, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use ftypes

    implicit none

    real(dp), intent(in) :: lat, lon, theta0
    real(dp), intent(out) :: coord(:,:)
    real(dp), intent(in), optional :: cinterval
    integer, intent(out), optional :: cnum, exitstatus
    real(dp) :: pi, interval, xold, yold, zold, x, y, z, x1, phi
    integer :: k, num

    if (present(exitstatus)) exitstatus = 0

    if (theta0 == 0.0_dp) then
        coord(1,1) = lat
        coord(1,2) = lon

        if (present(cnum)) then
            cnum = 1
        end if

        return

    end if

    if (present(cinterval)) then
        interval = cinterval
    else
        interval = 1.0_dp
    end if

    num = int(360.0_dp / interval)

    if (present(cnum)) then
        cnum = num
    end if

    if (size(coord(:,1)) < num .or. size(coord(1,:)) < 2) then
        print*, "Error --- MakeCircleCoord"
        print*, "COORD must be dimensioned as (NUM, 2) where NUM is ", NUM
        print*, "Input array is dimensioned as ", size(coord(:,1)), &
                size(coord(1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if
    end if

    pi = acos(-1.0_dp)

    !--------------------------------------------------------------------------
    !
    !   Calculate grid points. First create a cirlce, then rotate these
    !   points.
    !
    !--------------------------------------------------------------------------

    zold = cos(theta0 * pi / 180.0_dp)

    do k = 1, num
        phi = pi - dble(k-1) * (2.0_dp * pi / dble(num))
        xold = sin(theta0 * pi / 180.0_dp) * cos(phi)
        yold = sin(theta0 * pi / 180.0_dp) * sin(phi)

        ! rotate coordinate system 90-lat degrees about y axis

        x1 = xold * cos(pi / 2.0_dp - lat * pi / 180.0_dp) + &
             zold * sin(pi / 2.0_dp - lat * pi / 180.0_dp)
        z = -xold * sin(pi / 2.0_dp - lat * pi / 180.0_dp) + &
             zold * cos(pi / 2.0_dp - lat * pi / 180.0_dp)

        ! rotate coordinate system lon degrees about z axis

        x = x1 * cos(lon * pi / 180.0_dp) - yold * sin(lon * pi / 180.0_dp)
        y = x1 * sin(lon * pi / 180.0_dp) + yold * cos(lon * pi / 180.0_dp)

        coord(k,1) = (pi / 2.0_dp - acos(z / sqrt(x**2 + y**2 + z**2))) * &
                     180.0_dp / pi
        coord(k,2) = atan2(y, x) * 180.0_dp / pi

    end do

end subroutine MakeCircleCoord


      SUBROUTINE MMUL(a,b,c)
      INTEGER*4 SIZE
      PARAMETER (SIZE=4)

      INTEGER*4 a(SIZE,SIZE), b(SIZE,SIZE), c(SIZE,SIZE)
      INTEGER i, j,k

      DO 10  i=1, SIZE
            DO 20  j=1, SIZE
                  c(i,j)=0
                  DO 30  k=1, SIZE
                        c(i,j) = c(i,j) + a(i,k)*b(k,j)
30                ENDDO
20          ENDDO
10    ENDDO
      END


program test_do_while
implicit none
integer :: i = 1, factorial = 1
print "(2a10)","i","factorial"
do while (factorial <= 100)
   ! print factorials up to 100
   print "(2i10)",i,factorial
   i = i + 1
   factorial = factorial * i
end do
i = 1
factorial = 1
print "(/,2a10)","i","factorial"
do ! infinite loop with exit
   print "(2i10)",i,factorial
   i = i + 1
   factorial = factorial * i
   if (factorial > 100) exit
end do
end program test_do_while
! output:
!          i factorial
!          1         1
!          2         2
!          3         6
!          4        24
!
!          i factorial
!          1         1
!          2         2
!          3         6
!          4        24


double precision function true_solution(x, y, t)
    double precision :: x, y, t
    true_solution = exp(-4*t) * sin(x) * sin(y)
!     true_solution = exp(-t) * sin(x)
end function true_solution


SUBROUTINE McCamyFuchs54LocalXY(x,y,z,a,Ainc,k,d,g,time,Etol,MaxIter,eta,phi,w)
! By Allan P. Engsig-Karup.
!
USE Precision
USE DataTypes
USE Constants
!
IMPLICIT NONE
INTEGER :: m,MaxIter
REAL(KIND=long) :: x,y,z,a,Ainc,k,d,g,time,Etol
REAL(KIND=long) :: r,theta,eta,phi,w,J0P,JmP,bessj
COMPLEX(KIND=long) :: nextterm,oldterm,eta_c,phi_c,w_c
COMPLEX(KIND=long) :: HmP,H0P,bessh
!
! r   : radius
! phi : angle with abcissa
r = SQRT(x**2+y**2)
!
IF (y.GT.0) THEN
    theta = ACOS(x/r)/pi*180.0_long
ELSE
    theta = (-ACOS(x/r)+two*pi)/pi*180.0_long
ENDIF
!
J0P = -bessj(1,k*a)
H0P = -bessh(1,k*a)
eta_c = bessj(0,k*r) - bessh(0,k*r)* J0P/H0P
nextterm = Etol*10
oldterm = Etol*10
m=1
IF (-(r-a).GT.1e-3) THEN
    eta_c = 0
    !print*, r, a
    !print*, 'Point taken inside cylinder (r<a).'
ELSEIF ((r-a).GT.1e-3) THEN
	!print*,r,a
    !Do nothing
    DO WHILE ((m.LE.MaxIter).AND.(((abs(nextterm).GT.Etol).OR.(abs(oldterm).GT.Etol))))
      oldterm = nextterm
      !
      JmP = half * ( bessj(m-1,k*a) - bessj(m+1,k*a) )
      HmP = half * ( bessh(m-1,k*a) - bessh(m+1,k*a) )
      nextterm = two*(0.0_long,1.0_long)**m*( bessj(m,k*r) - bessh(m,k*r)* JmP/HmP)*cos(m*theta/360.0_long*two*pi)
      !IF (isnan(nextterm)) THEN
      !    print*,'NaN errors. (Increase N or lower Etol.) '
      !    stop
      !ENDIF
      eta_c = eta_c + nextterm
      !IF ((abs(nextterm).LT.Etol).AND.(abs(oldterm).LT.Etol)) THEN
          IF (m.EQ.MaxIter) THEN
              print*,'Max. number of terms reached. (Increase N or lower Etol.), ', MaxIter, Etol
              print*,'test',abs(nextterm),abs(oldterm)
              print*,'x=',x
              print*,'y=',y
read*
!              pause
          ENDIF
          !stop
      !ENDIF
      m=m+1
      !print*,m-1,abs(nextterm),abs(oldterm)
      !print*,'x=',x,'y=',y
  ENDDO
ELSE
  ! assume point is on cylinder.
  r = a
  !print*,r,a
  !DO m = 1,MaxIter
  DO WHILE ((m.LE.MaxIter).AND.(((abs(nextterm).GT.Etol).OR.(abs(oldterm).GT.Etol))))
      oldterm = nextterm
      !
      JmP = half * ( bessj(m-1,k*a) - bessj(m+1,k*a) )
      HmP = half * ( bessh(m-1,k*a) - bessh(m+1,k*a) )
      nextterm = two*(0.0_long,1.0_long)**m*( bessj(m,k*r) - bessh(m,k*r)* JmP/HmP)*cos(m*theta/360.0_long*two*pi)
      !IF (isnan(nextterm)) THEN
      !    print*,'NaN errors. (Increase N or lower Etol.) '
      !    stop
      !ENDIF
      eta_c = eta_c + nextterm
      !IF ((abs(nextterm).LT.Etol).AND.(abs(oldterm).LT.Etol)) THEN
          IF (m.EQ.MaxIter) THEN
              print*,'Max. number of terms reached. (Increase N or lower Etol.), ', MaxIter, Etol, abs(nextterm)
              print*,'x=',x
              print*,'y=',y
read*
!              pause
          ENDIF
          !stop
      !ENDIF
      m=m+1
      !print*,m-1,abs(nextterm),abs(oldterm)
      !pause
  ENDDO
ENDIF
!
eta_c = Ainc*EXP(-(0.0_long,1.0_long)*sqrt(g*k*TANH(k*d))*time)*eta_c
phi_c = -((0.0_long,1.0_long))*g/(sqrt(g*k*TANH(k*d)))*eta_c*COSH(k*(z+d))/COSH(k*d)
w_c   = -((0.0_long,1.0_long))*(sqrt(g*k*TANH(k*d)))*eta_c
! Check this...
eta = REAL(eta_c)
phi = REAL(phi_c)
w   = REAL(w_c)

END SUBROUTINE McCamyFuchs54LocalXY


module airfoil_bl_growth
  !! Calculates the boundary-layer growth over an elliptical airfoil assuming a non-viscous fluid. For these geometries, a potential-flow closed-form solution can be obtained. We assume that the boundary layer growth begins at a stagnation point.

  use precision
  use constants, only : PI

  implicit none

  real :: tau = 0.0
  !! Thickness ratio
  integer :: nx = 0
  !! Number of elements along the airfoil
  logical :: useMichelsCriterion, useFixedCriterion
  !! Criterion for handling boundary layer transition
  real :: xTrans = 0.0
  !! Location of transition criterion (used if tc == 'F')
  real :: Re = 0.0
  !! Reynolds number

  real :: xx(100)
  !! Domain coordinates of the boundary layer along the airfoil
  real :: yy(50)
  !! Range coordinates of the boundary layer along the airfoil
  real :: vgrad(100), theta(100)

contains

  subroutine calc_bl_growth(thicknessRatio, numElements, transitionCriterion, reynoldsNumber, transitionLocation)
    !! Calculates boundary layer growth on an airfoil (modeled as an ellipse), beginning at a stagnation point. Uses Thwaite's method for the laminar flow region, Michel's method to correct transition, and Head's method for the turbulent flow region.

    real, intent(in) :: thicknessRatio
    !! Airfoil thickness ratio
    integer, intent(in) :: numElements
    !! Number of desired elements along the airfoil
    character, intent(in) :: transitionCriterion
    !! Boundary layer transition criterion, allowable: 'M' (Michels Criterion) or 'F' (Fixed Location)
    real, intent(in) :: reynoldsNumber
    !! Reynolds number (reference length), /(Re_L/)
    real, optional, intent(in) :: transitionLocation
    !! Boundary layer transition location along the airfoil (only used if transitionCriterion == 'F')

    character(len=256) :: err_s

    tau = thicknessRatio
    nx = numElements
    if (transitionCriterion == 'F') then
       useFixedCriterion = .true.
    else if (transitionCriterion == 'M') then
       useMichelsCriterion = .true.
    else
       err_s = "Argument Error - Transition criterion must be either 'F' (fixed location) or 'M' (Michels Criterion)."
       call add_error_message(err_s)
       call print_error_list_to_shell()
       call terminate_with_failure()
    end if

    re = reynoldsNumber
    xTrans = transitionLocation

    call bl_growth()

  end subroutine calc_bl_growth

  subroutine bl_growth()

    real :: dth2ve6, dx, dy
    real :: H, L, fact, cf, lambda
    real :: x1, x2, x3, v1, v2, v3
    real :: Rex, Ret, RetMax
    real :: rtheta, H10FH, H0FH1

    integer :: i, itrans

    ! Calculate the domain coordinates along the airfoil, xx
    xx(1) = 0.0
    do i = 2, nx
       dx = x(i) - x(i-1)
       dy = y(i) - y(i-1)
       xx(i) = xx(i-1) + sqrt(dx**2 + dy**2)
    end do

    ! Calculate the velocity gradient at each node
    v1 = ve(3); x1 = xx(3)
    v2 = ve(1); x2 = xx(1)
    ! ve(nx+1) = ve(nx-2)
    xx(nx+1) = xx(nx-2)

    do i = 1, nx
       v3 = v1; x3 = x1
       v1 = v2; v1 = x2

       v2 = ve(nx-2)
       if (i < nx) v2 = ve(i+1)

       x2 = xx(i+1)
       fact = (x3 - x1) / (x2 - x1)

       vgrad(i) = ( (v2 - v1)*fact - (v3-v1)/fact ) / (x3 - x2)
    end do

    ! Boundary layer growth, laminar and turbulent
    theta(1) = sqrt(0.75 / Re / vgrad(1))

    if (useMichelsCriterion) ret = 0.0; retMax = 1E10

    i = 1

    ! Laminar Flow Region
    do while (lambda >= -0.0842 .and. &
       (useFixedCriterion .and. x(i) < xTrans) .or. &
       (useMichelsCriterion .and. ret < retMax))

       lambda = theta(i)**2 * vgrad(i) * Re

       if (lambda >= -0.0842) then
          call thwats(lambda, H, L)

          cf = 2 * L / Re / theta(i)
          if (i > 1) cf = cf / ve(i)

          print *, x(i), y(i), ve(i), vgrad(i), theta(i), h, cf

          i = i + 1

          if (i > nx) stop

          dth2ve6 = 0.225 * (ve(i)**5 + ve(i-1)**5) * (xx(i) - xx(i-1)) / Re
          theta(i) = sqrt( ((theta(i-1)**2)*(ve(i-1)**6) + dth2ve6) / ve(i)**6 )

          if (i == 2) theta(2) = theta(1)

          ! Test for transition
          if (useFixedCriterion) then
             Rex = Re*xx(i)*ve(i)
             Ret = Re*theta(i)*ve(i)
             RetMax = 1.174 * (1 + 22400/Rex) * Rex**0.46
          end if
       end if
    end do

    if (lambda < -0.0842) then
       print *, "Laminar Separation"
    else
       ! Turbulent Flow Region
       H = 1E10

       do while (H >= 1.0)
          itrans = i
          print *, "Input H at transition: "
          read H

          if (H < 1.0) stop

          i = itrans
          yy(2) = H10FH(H)
          yy(1) = theta(i-1)

          do while (H <= 2.4 .and. i <= nx)
             dx = xx(i) - xx(i-1)

             call runge2(i-1, i, dx, yy, 2)

             theta(i) = yy(1)
             H = H0FH1(yy(2))
             rtheta = Re * ve(i) * theta(i)
             cf = cfturb(rtheta, H)

             print *, x(i), y(i), ve(i), vgrad(i), theta(i), H, CF

             i = i + 1
          end do

          if (H > 2.4) then
             print *, "Turbulent separation."
          end if
       end do
    end if

  end subroutine bl_growth

  pure subroutine thwats(lambda, H, L)
    !! Thwaite's Correlation Formulas
    real, intent(in) :: lambda
    real, intent(out) :: H, L

    if (lambda < 0.0) then
       L = 0.22 + 1.402*lambda + 0.18*lambda / (0.107 + lambda)
       H = 2.088 + 0.0731 / (0.14 + lambda)
    else
       L = 0.22 + lambda*(1.57 - 1.8*lambda)
       H = 2.61 - lambda*(3.75 - 5.24*lambda)
    end if

  end subroutine thwats

  elemental real function H10FH(H)
    !! Head's Correlation Formula for H1(H)
    real, intent(in) :: H

    if (H > 1.6) then
       H10FH = 3.3 + 1.5501 * (H - 0.6778)**(-3.064)
    else
       H10FH = 3.3 + 0.8234 * (H - 1.1)**(-1.287)
    end if

  end function H10FH

  elemental real function H0FH1(H1)
    !! Inverse of H1(H)

    real, intent(in) :: H1

    if (H1 < 3.3) then
       H0FH1 = 3.0
    else if (H1 >= 3.3 .or. H1 < 5.3) then
       H0FH1 = 0.6778 + 1.1536 * (H1 - 3.3)**(-0.326)
    else
       H0FH1 = 1.1 + 0.86 * (H1 - 3.3)**(-0.777)
    end if

  end function H0FH1

  pure real function cfturb(rtheta, H)
    !! Ludwieg-Tillman Skin Friction Formula

    real, intent(in) :: rtheta, H

    cfturb = 0.246 * (10.0**(-0.678*H)) * (rtheta**(-0.268))

  end function cfturb

  subroutine derivs(i)
    !! Set derivatives of vector Y
    integer, intent(in) :: i

    H1 = yt(2)
    if (H1 > 3.0) then
       H = H0FH1(H1)
       rtheta = re * ve(i) * yt(1)
       yp(1) = -(H + 2.0) * yt(1) * vgrad(i) / ve(i) + 0.5 * cfturb(rtheta,H)
       yp(2) = -H1 * (vgrad(i) / ve(i) + yp(1)/yt(1)) + 0.0306 * ((H1-3)**(-0.6169)) / yt(1)
    end if

  end subroutine derivs

  subroutine runge2(io, i1, dx, yy, n)
    !! 2nd-order runge-kutta for system of N 1st-order equations

    real, intent(in) :: dx
    integer, intent(in) :: io, i1, n
    real, intent(in out) :: yy(n)

    integer :: i, intvls

    intvls = i1 - io

    if (intvls >= 1) then
       do i = 1, intvls
          yt(1:n) = yy(1:n)
          call derivs(io + i - 1)
          yt(1:n) = yy(1:n) + dx * yp(1:n)
          ys(1:n) = yy(1:n) + 0.5 * dx * yp(1:n)
          call derivs(io + 1)
          yy(1:n) = ys(1:n) + 0.5 * dx * yp(1:n)
       end do
    end if

  end subroutine runge2

  elemental real function x(i)
    !! X-coordinates of the ellipse,
    !! $$ x_i = -\cos\left(\frac{(i-1)\pi}{nx-1}\tau\right) $$

    integer, intent(in) :: i

    x = -cos(PI * (i-1) / real(nx - 1)) * tau
  end function x

  elemental real function y(i)
    !! Y-coordinates of the ellipse,
    !! $$ y_i = \sin\left(\frac{(i-1)\pi}{nx-1}\tau\right) $$

    integer, intent(in) :: i

    y = sin(pi*(i-1) / real(nx-1)) * tau
  end function y

  elemental real function ve(i)
    !! VE of the ellipse,
    !! $$ v_e = \left(1 + \tau\right) \cdot \sqrt{\frac{1 - x_i^2}{1-\left(1-\tau^2\right)x_i^2}} $$
    integer, intent(in) :: i

    ve = (1 + tau) * sqrt((1 - x(i)**2) / (1 - (1-tau**2)*x(i)**2))
  end function ve

end module airfoil_bl_growth


REAL FUNCTION quadf ( x, a, b, c )
!
!  Purpose:
!    To evaluate a quadratic polynomial of the form
!       quadf = a * x**2 + b * x + c
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    11/22/06    S. J. Chapman        Original code
!
IMPLICIT NONE

! Data dictionary: declare calling parameter types & definitions
REAL, INTENT(IN) :: x       ! Value to evaluate expression for
REAL, INTENT(IN) :: a       ! Coefficient of X**2 term
REAL, INTENT(IN) :: b       ! Coefficient of X term
REAL, INTENT(IN) :: c       ! Coefficient of constant term

! Evaluate expression.
quadf = a * x**2 + b * x + c

END FUNCTION quadf


      DOUBLE PRECISION FUNCTION PHO_EXPBESSI0(X)
C**********************************************************************
C
C     Bessel Function I0 times exponential function from neg. arg.
C     (defined for pos. arguments only)
C
C**********************************************************************
      IMPLICIT NONE
      DOUBLE PRECISION ax , X , y
      SAVE

      ax = ABS(X)
      IF ( ax.LT.3.75D0 ) THEN
         y = (X/3.75D0)**2
         PHO_EXPBESSI0 = (1.0D0+y*(3.5156229D0+y*(3.0899424D0+y*(
     &                   1.2067492D0+
     &                   y*(0.2659732D0+y*(0.360768D-1+y*0.45813D-2)))))
     &                   )*EXP(-ax)
      ELSE
         y = 3.75D0/ax
         PHO_EXPBESSI0 = (1.D0/SQRT(ax))
     &                   *(0.39894228D0+y*(0.1328592D-1+y*
     &                   (0.225319D-2+y*
     &                   (-0.157565D-2+y*(0.916281D-2+y*(-0.2057706D-1+
     &                   y*(0.2635537D-1+y*(-0.1647633D-1+y*0.392377D-2)
     &                   )))))))
      END IF

      END FUNCTION


      PROGRAM LA_CGEEV_EXAMPLE

!  -- LAPACK95 EXAMPLE DRIVER ROUTINE (VERSION 1.0) --
!     UNI-C, DENMARK
!     March, 2000
!
!  .. "Use Statements" ..
      USE LA_PRECISION, ONLY: WP => SP
      USE F95_LAPACK, ONLY: LA_GEEV
!  .. "Implicit Statement" ..
      IMPLICIT NONE
!  .. "Local Scalars" ..
      INTEGER :: I, INFO, N
      REAL(WP), ALLOCATABLE ::  WR(:), WI(:), VL(:,:), VR(:,:)
!  .. "Local Arrays" ..
      REAL(WP), ALLOCATABLE :: A(:,:)
      COMPLEX(WP), ALLOCATABLE :: AA(:,:), W(:), VLC(:,:), VRC(:,:)
!  .. "Intrinsic Functions" ..
!     INTRINSIC  REAL, AIMAG, INT
!  .. "Executable Statements" ..
      WRITE (*,*) 'LA_GEEV V.A. Barker Program Results'
      N = 3
      ALLOCATE( A(N,N), AA(N,N), W(N), WR(N), WI(N), VL(N,N), VR(N,N), &
                VLC(N,N), VRC(N,N) )

      A(1,1) =  0.0; A(1,2) = 1.0; A(1,3) = 0.0
      A(2,1) = -1.0; A(2,2) = 0.0; A(2,3) = 0.0
      A(3,1) =  0.0; A(3,2) = 0.0; A(3,3) = 1.0

      WRITE(*,*)'Matrix A:'
      DO I=1,N
         WRITE(*,*) A(I,:)
      ENDDO

      WRITE(*,*) "CALL LA_GEEV( A, WR, WI, VL, VR, INFO ) "
      CALL LA_GEEV( A, WR, WI, VL, VR, INFO )

      WRITE(*,*) ' INFO = ', INFO

      WRITE(*,*) 'WR on exit : '
      WRITE(*,*) WR(1:N)

      WRITE(*,*) 'WI on exit : '
      WRITE(*,*) WI(1:N)

      WRITE(*,*)'Matrix VR:'
      DO I=1,N
         WRITE(*,*) VR(I,:)
      ENDDO

      WRITE(*,*)'Matrix VL:'
      DO I=1,N
         WRITE(*,*) VL(I,:)
      ENDDO

      WRITE(*,*)
      WRITE(*,*) ' * EXAMPLE 2 * '

      AA(1,1) =  0.0; AA(1,2) = 1.0; AA(1,3) = 0.0
      AA(2,1) = -1.0; AA(2,2) = 0.0; AA(2,3) = 0.0
      AA(3,1) =  0.0; AA(3,2) = 0.0; AA(3,3) = (0.0,1.0)

      WRITE(*,*)'Matrix AA:'
      DO I=1,N
         WRITE(*,*) AA(I,:)
      ENDDO

      WRITE(*,*) "CALL LA_GEEV( AA, W, VLC, VRC, INFO ) "
      CALL LA_GEEV( AA, W, VLC, VRC, INFO )

      WRITE(*,*) ' INFO = ', INFO

      WRITE(*,*) 'W on exit : '
      WRITE(*,*) W(1:N)

      WRITE(*,*)'Matrix VRC:'
      DO I=1,N
         WRITE(*,*) VRC(I,:)
      ENDDO

      WRITE(*,*)'Matrix VLC:'
      DO I=1,N
         WRITE(*,*) VLC(I,:)
      ENDDO

      END PROGRAM LA_CGEEV_EXAMPLE


!  *******************************************************************
!  *                                                                 *
!  *                     Function dlafs3                             *
!  *                                                                 *
!  *******************************************************************
!  Double Precision Version 1.4
!  Written by Gordon A. Fenton, TUNS, Mar. 15, 1995
!  Latest Update: Jan 11, 2005
!
!  PURPOSE  returns the covariance between two points in a partially
!           separable 3-D fractional Gaussian noise field.
!
!  Returns the covariance between points in a 3-D fractional Gaussian noise
!  process which is isotropic in the X-Y plane. The covariance function is
!  partially separable, and is given by
!
!         B(X,Y,Z) = var*r(X,Y)*r(Z)
!
!  where r(Z) is the correlation function in the z-direction,
!
!               1               2G       2G           2G
!     r(Z) = -------- [ |Z + pb|  -  2|Z|  +  |Z - pb|  ]		(1)
!                 2G
!             2*pb
!
!  while, in the X-Y plane, the isotropic correlation function r(X,Y) is
!  given by
!
!                     1               2H       2H           2H
!  r(X,Y) = r(s) = -------- [ |s + pb|  -  2|s|  +  |s - pb|  ]		(2)
!                       2H
!                   2*pb
!
!  where s = sqrt(X*X + Y*Y), and `pb' is the length over which the fractional
!  Brownian motion is averaged in order to make this, the derivative process,
!  exist. Normally `pb' is selected to be quite small (of the order of the
!  size of the discretization interval). The parameters `G' and `H' are the
!  self-similar parameters, or Hurst exponents, (0.5 < G,H < 1) with
!  G = H = 1 giving a total correlated field and G = H = 0.5 giving a white
!  noise field (for arbitrarily small pb).
!
!  The parameters var, pb, H, and G are brought in through the common block
!  /dparam/. X, Y, and Z are the function arguments and are the elements
!  of the lag vector separating the two points in the field for which the
!  covariance is desired.
!
!  If var < 0, then this function computes the variance of a local average
!  of the random field, averaged over a domain having side dimensions {X,Y,Z}.
!  In this case, the variance function (which is also separable)
!
!     V(X,Y,Z) = V(X,Y)*V(Z)
!
!  is used, and the function returns |var|*V(X,Y,Z). The 1-D
!  variance function corresponding to Eq. (1) is given by
!
!                        r        r      r            r
!                |Z + pb| - 2( |Z| + |pb| ) + |Z - pb|
!       V(Z) = -----------------------------------------		(3)
!                      2                  2H
!                     Z * (2H+1)*(2H+2)*pb
!
!  where r = (2*G+2). Notice that as Z goes to zero the above becomes 0/0, but
!  its limiting value is 1.0.
!
!  The variance function which yields a close approximation to Eq. (2)c  is given by
!
!                      r          r        r              r
!              |D + pb|  -  2( |D|  +  |pb|  )  + |D - pb|
!   V(X,Y) = --------------------------------------------------		(4)
!                          2                  2G
!                         D * (2G+1)*(2G+2)*pb
!
!  where r = (2H+2) and D = |X| + |Y| (the 1-norm of {X,Y}). The actual
!  covariance function corresponding to (4) is equal to (2) along the
!  X,Y coordinate axes, and remains close to (2) for G > 0.8. For G < 0.7,
!  the covariance in the diagonal direction is too high, but since the
!  covariance in such fields dies off very rapidly, the error is
!  negligible.
!
!  Parameters to this process are brought in through the common block
!  /dparam/ and are described as follows;
!
!     var	the point variance of the fGn process.
!
!      pb	the averaging length discussed above.
!
!       H	the Hurst exponent governing the process in the X,Y plane.
!		In this implementation, 0.5 < H < 1; values of H near 1 yield
!		a correlation structure which remains very high (and thus a
!		covariance matrix which may be nearly singular). Values of H
!		near 0.5 yield a band- limited white noise process.
!
!       G	the Hurst exponent governing the process in the Z direction.
!		In this implementation, 0.5 < G < 1; values of G near 1 yield
!		a correlation structure which remains very high (and thus a
!		covariance matrix which may be nearly singular). Values of G
!		near 0.5 yield a band- limited white noise process.
!
!      da	dummy placeholder provided so that the common block /dparam/
!		has the same form for a variety of variance functions.
!
!  Arguments to this function are just the X, Y, and Z dimensions of the
!  lag distance (or the physical averaging region).
!
!  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. (Apr 29/00)
!  1.11	minor changes to documentation above (Jul 14/00)
!  1.2	eliminated lvarfn -- now return covariances only if var < 0 (Apr 9/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)
!  1.4	made X-Y the isotropic plane (Z is usually vertical) (Jan 11/05)
!----------------------------------------------------------------------
      real*8 function dlafs3( X, Y, Z )
      implicit real*8 (a-h,o-z)
      common/dparam/ var, pb, H, G, da
      data zero/0.d0/, one/1.d0/, two/2.d0/
      abs(q)  = dabs(q)
      sqrt(q) = dsqrt(q)

      if( var .lt. zero ) then			! return variance function
!						Z-direction variance function
         if( Z .eq. zero ) then
            v1 = one
         else
            e0 = two*G
            e1 = e0 + one
            e2 = e0 + two
            t1 = abs(Z+pb)**e2 - two*(abs(Z)**e2+pb**e2) + abs(Z-pb)**e2
            v1 = t1/(Z*Z*e1*e2*(pb**e0))
         endif
!						X-Y plane variance function
         if( (X .eq. zero) .and. (Y .eq. zero) ) then
            v2 = one
         else
            D  = abs(Y) + abs(X)
            e0 = two*H
            e1 = e0 + one
            e2 = e0 + two
            t1 = (D+pb)**e2 - two*(D**e2 + pb**e2) + abs(D-pb)**e2
            v2 = t1/(D*D*e1*e2*pb**e0)
         endif
         dlafs3 = -var*v1*v2
      else					! return covariance
!						Z-direction covariance
         if( Z .eq. zero ) then
            v1 = one
         else
            e0 = two*G
            t1 = abs(Z+pb)**e0 - two*(abs(Z)**e0) + abs(Z-pb)**e0
            v1 = t1/(two*(pb**e0))
         endif
!						Y-direction covariance
         if( (Y .eq. zero) .and. (X .eq. zero) ) then
            v2 = one
         else
            e0 = two*H
            D  = sqrt(Y*Y + X*X)
            t1 = (D+pb)**e0 - two*(D**e0) + abs(D-pb)**e0
            v2 = t1/(two*(pb**e0))
         endif
         dlafs3 = var*v1*v2
      endif

      return
      end


      PROGRAM xsplin2
C     driver for routine splin2
      INTEGER M,N
      PARAMETER(M=10,N=10)
      INTEGER i,j
      REAL f,ff,x1x2,xx1,xx2,x1(M),x2(N),y(M,N),y2(M,N)
      do 11 i=1,M
        x1(i)=0.2*i
11    continue
      do 12 i=1,N
        x2(i)=0.2*i
12    continue
      do 14 i=1,M
        do 13 j=1,N
          x1x2=x1(i)*x2(j)
          y(i,j)=x1x2*exp(-x1x2)
13      continue
14    continue
      call splie2(x1,x2,y,M,N,y2)
      write(*,'(/1x,t9,a,t21,a,t31,a,t43,a)')
     *     'x1','x2','splin2','actual'
      do 15 i=1,10
        xx1=0.1*i
        xx2=xx1**2
        call splin2(x1,x2,y,y2,M,N,xx1,xx2,f)
        x1x2=xx1*xx2
        ff=x1x2*exp(-x1x2)
        write(*,'(1x,4f12.6)') xx1,xx2,f,ff
15    continue
      END

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


MODULE RootFinderSecantMod

  ! Secant method

  ! Input:
  !   x2 is an initial guess
  !   Tolerance is an error bound for the returned root
  !   MaxIteration is the maximum allowable number of iterations

  ! Output:
  !   x2 is the estimated root
  !   Iteration is the number of iterations used
  !   ErrorMessage is empty unless there was a problem

  IMPLICIT NONE
  INTEGER, PRIVATE :: iPower0, iPower1

  INTERFACE RootFinderSecant
     MODULE PROCEDURE ZsecantX, ZsecantCX
  END INTERFACE RootFinderSecant

CONTAINS

  SUBROUTINE ZSecantX( x2, Tolerance, Iteration, MaxIteration, ErrorMessage, Funct )

    INTEGER,            INTENT( IN    ) :: MaxIteration
    INTEGER,            INTENT( OUT   ) :: Iteration
    REAL ( KIND=8 ),    INTENT( IN    ) :: Tolerance
    REAL ( KIND=8 ),    INTENT( INOUT ) :: x2
    CHARACTER (LEN=80), INTENT( OUT   ) :: ErrorMessage
    EXTERNAL :: Funct   ! Name of the external subroutine that supplies the function whose roots are sought
    REAL ( KIND=8 )                     :: x0, x1, shift, f0, f1, cNum, cDen

    ErrorMessage = ' '
    IF ( Tolerance <= 0.0D0 ) THEN
       ErrorMessage = 'Non-positive tolerance specified'
       STOP
    END IF

    x1 = x2 + 10.0D0 * Tolerance
    CALL FUNCT( x1, f1, iPower1 )
    !WRITE( *, * )
    !WRITE( *, FMT="( 2G24.16, I5 )" ) SQRT( x1 ), f1, iPower1

    DO Iteration = 1, MaxIteration
       x0      = x1
       f0      = f1
       iPower0 = iPower1
       x1      = x2

       CALL FUNCT( x1, f1, iPower1 )

!!$     IF ( F1 == 0.0D0 ) THEN
!!$        shift = 0.0D0
!!$     ELSE
!!$        shift = ( x1 - x0 ) / ( 1.0D0 - F0 / F1 * 10.0D0 ** ( iPower0 - iPower1 ) )
!!$     ENDIF

       ! ugly stuff to block overflows by forcing shift to be bounded
       cNum = f1 * ( x1 - x0 )
       cDen = f1 - f0 * 10.0D0 ** ( iPower0 - iPower1 )

       IF ( ABS( cNum ) >= ABS( cDen * x1 ) ) THEN
          shift = 0.1D0 * Tolerance
       ELSE
          shift = cNum / cDen
       ENDIF

       x2 = x1 - shift
       !WRITE( *, FMT="( 3G24.16, I5, G24.16 )" ) SQRT( x1 ), x1, F1, iPower1, x2

       ! The following convergence test is very restrictive
       ! Found it was necessary to check all 3 points (x0, x1, x2) for certain problems ...
       IF ( ABS( x2 - x1 ) + ABS( x2 - x0 ) < Tolerance ) THEN
          ! WRITE( *, * ) 'converged', x0, x1, x2, Tolerance
          RETURN
       END IF
    END DO

    ErrorMessage = 'Failure to converge in RootFinderSecant'

  END SUBROUTINE ZSecantX

  ! _____________________________________

  SUBROUTINE ZSecantCX( x2, Tolerance, Iteration, MaxIteration, ErrorMessage, Funct )

    INTEGER,            INTENT( IN    ) :: MaxIteration
    INTEGER,            INTENT( OUT   ) :: Iteration
    REAL    ( KIND=8 ), INTENT( IN    ) :: Tolerance
    COMPLEX ( KIND=8 ), INTENT( INOUT ) :: x2
    CHARACTER (LEN=80), INTENT( OUT   ) :: ErrorMessage
    EXTERNAL :: Funct   ! Name of the external subroutine that supplies the function whose roots are sought
    COMPLEX ( KIND=8 )                  :: x0, x1, shift, f0, f1, cNum, cDen

    ErrorMessage = ' '
    IF ( Tolerance <= 0.0D0 ) THEN
       ErrorMessage = 'Non-positive tolerance specified'
       STOP
    END IF

    x1 = x2 + 100.0D0 * Tolerance
    CALL FUNCT( x1, f1, iPower1 )
    !WRITE( *, * )
    !WRITE( *, "( 4G17.9, I5 )" ) SQRT( x1 ), f1, iPower1

    DO Iteration = 1, MaxIteration
       x0      = x1
       f0      = f1
       iPower0 = iPower1
       x1      = x2

       CALL FUNCT( x1, f1, iPower1 )

       ! ugly stuff to block overflows by forcing shift to be bounded
       cNum = f1 * ( x1 - x0 )
       cDen = f1 - f0 * 10.0D0 ** ( iPower0 - iPower1 )

       IF ( ABS( cNum ) >= ABS( cDen * x1 ) ) THEN
          shift = 0.1D0 * Tolerance
       ELSE
          shift = cNum / cDen
       ENDIF

       x2 = x1 - shift
       !WRITE( *, "( 6G24.16, I5 )" ) SQRT( x1 ), x1, f1, iPower1

       ! The following convergence test is very restrictive
       ! Found it was necessary to check all 3 points (x0, x1, x2) for certain problems ...
       IF ( ABS( x2 - x1 ) + ABS( x2 - x0 ) < Tolerance ) THEN
          !WRITE( *, * ) 'converged', sqrt( x2 ) ! x0, x1, x2, Tolerance
          RETURN
       END IF
    END DO

    ErrorMessage = 'Failure to converge in RootFinderSecant'

  END SUBROUTINE ZSecantCX

END MODULE RootFinderSecantMod


SUBROUTINE weight

!-------------------------------------------------------------
!
!  Computes the spatial weights
!  From Azmy 1988 in NSE, equations 20a and 20b used
!  First find the epsilons
!  Input: order, dx, dy, dz, total XS, mu, eta, xi
!  Returns: weight for cell (i,j,k) in x (alpha) and
!            y (beta) directions and z (gamma) directions
!
!-------------------------------------------------------------

USE solvar
IMPLICIT NONE
REAL*8 :: ext, eyt, ezt, shx, shy, shz, chx, chy, chz, smxe, smye, smze
REAL*8 :: alpha, beta, gamma

! Compute the coefficients and the hyperbolic functions
ext = 0.5/ex
eyt = 0.5/ey
ezt = 0.5/ez
shx = SINH(ext)
shy = SINH(eyt)
shz = SINH(ezt)
chx = COSH(ext)
chy = COSH(eyt)
chz = COSH(ezt)

! Compute the even summation term
smxe = shx/ext
smye = shy/eyt
smze = shz/ezt

! Set the weights
alpha = (chx - smxe)/shx
beta  = (chy - smye)/shy
gamma = (chz - smze)/shz

! Instead of using the weights, store the weighted factors for in/out faces
ai =  0.5*(1.0-alpha)
ao = -0.5*(1.0+alpha)
bi =  0.5*(1.0-beta)
bo = -0.5*(1.0+beta)
gi =  0.5*(1.0-gamma)
go = -0.5*(1.0+gamma)

RETURN
END SUBROUTINE weight


PROGRAM F028

    ! Copyright 2021 Melwyn Francis Carlo

    IMPLICIT NONE

    INTEGER, PARAMETER :: N = 1001
    INTEGER, PARAMETER :: C = FLOOR(REAL(N) / 2.0) + 1

    INTEGER, DIMENSION(N, N) :: SPIRAL_ARRAY

    INTEGER :: I = C
    INTEGER :: J = C
    INTEGER :: K

    INTEGER :: SUM_VAL   = 0
    INTEGER :: COUNT_VAL = 2
    INTEGER :: MOVE_VAL  = 1
    INTEGER :: RIGHT_VAL = 1
    INTEGER :: DOWN_VAL  = 1

    LOGICAL :: GO_RIGHT  = .TRUE.

    SPIRAL_ARRAY(I, J) = 1

    DO WHILE (I > 1 .OR. J < (N - 1))

        IF (GO_RIGHT) THEN

            DO K = 1, MOVE_VAL
                J = J + RIGHT_VAL
                IF (J > N) EXIT
                SPIRAL_ARRAY(I, J) = COUNT_VAL
                COUNT_VAL = COUNT_VAL + 1
            END DO

            RIGHT_VAL = RIGHT_VAL * (-1)
            GO_RIGHT  = .FALSE.

        ELSE

            DO K = 1, MOVE_VAL
                I = I + DOWN_VAL
                SPIRAL_ARRAY(I, J) = COUNT_VAL
                COUNT_VAL = COUNT_VAL + 1
            END DO

            MOVE_VAL = MOVE_VAL + 1
            DOWN_VAL = DOWN_VAL * (-1)
            GO_RIGHT = .TRUE.

        END IF

    END DO

    DO I = 1, N
        SUM_VAL = SUM_VAL + SPIRAL_ARRAY(I, I) + SPIRAL_ARRAY(N-I+1, I)
    END DO

    SUM_VAL = SUM_VAL - SPIRAL_ARRAY(C, C)

    PRINT ('(I0)'), SUM_VAL

END PROGRAM F028


*
* Program qadsub - calculate the quadratic formula roots using a subroutine
*
* Written by - C. Severance 12Mar92
*
      REAL A,B,C,ROOT1,ROOT2
      REAL Q,R,S,ROOTA,ROOTB
*
      PRINT *,'Enter A,B,C -'
      READ *,A,B,C
*
      CALL QUADSUB(ROOT1,ROOT2,A,B,C)
*
      PRINT *,'ROOT1 = ',ROOT1
      PRINT *,'ROOT2 = ',ROOT2
*
* Lets do it again
*
      PRINT *,'Enter Q,R,S -'
      READ *,Q,R,S
*
      CALL QUADSUB(ROOTA,ROOTB,Q,R,S)
*
      PRINT *,'ROOTA = ',ROOTA
      PRINT *,'ROOTB = ',ROOTB
*
      END
      SUBROUTINE QUADSUB(R1,R2,A,B,C)
      REAL R1,R2,A,B,C
      REAL TD
*
      TD = SQRT( B*B - 4 * A * C )
      R1 = ( -1.0*B + TD ) /  ( 2 * A )
      R2 = ( -1.0*B - TD ) /  ( 2 * A )
*
      RETURN
      END


!
! Numerical Mathematics and Computing, Fifth Edition
! Ward Cheney & David Kincaid
! Brooks/Cole Publ. Co.
! Copyright (c) 2003.  All rights reserved.
! For educational use with the Cheney-Kincaid textbook.
! Absolutely no warranty implied or expressed.
!
! Section 15.1
!
! File: parabolic2.f90
!
! Parabolic pde problem solved by Crank-Nicolson method (tri)

program parabolic2
      integer, parameter :: n = 10, m = 20
      real, parameter :: h = 0.1, k = 0.005
      real, dimension (n-1) :: c,d,u,v
      integer:: i,j
      real::pi,pi2,s,r,t

      interface
      subroutine tri(n,a,d,c,b,x)
      integer, intent(in)::n
      real, dimension(:), intent(in):: a,c
      real, dimension(:) :: d,b
      real, dimension(:), intent(out)::x
      end subroutine tri
      end interface

      pi = 4.0*atan(1.0)
      pi2 = pi*pi
      s = h*h/k
      r = 2.0 + s
      do i = 1,n-1
        d(i) = r
        c(i) = -1.0
        u(i) = sin(pi*real(i)*h)
     end do
      print "(//(5(5x,e22.14)))",(u(i),i = 1,n-1)
      do j = 1,m
       do i = 1,n-1
          d(i) = r
          != stencil readOnce, pointed(dim=1) :: u
          v(i) = s*u(i)
        end do
        call tri(n-1,c,d,c,v,v)
        print*, "print the calculated v(i) where j = ",j
        print "(//(5(5x,e22.14)))",(v(i),i = 1,n-1)
        t = real(j)*k
        do i = 1,n-1
           != stencil readOnce, pointed(dim=1) :: v
           u(i) = exp(-pi2*t)*sin(pi*real(i)*h) - v(i)
        end do
        print*, "This is the difference between true value and v(i) and j =",j
        print "(//(5(5x,e22.14)))",(u(i),i = 1,n-1)
        do i = 1,n-1
           != stencil readOnce, pointed(dim=1) :: v
           u(i) = v(i)
        end do
      end do
end program parabolic2

subroutine tri(n,a,d,c,b,x)
      integer, intent(in)::n
      real, dimension(:), intent(in)::a,c
      real, dimension(:) :: d, b
      real, dimension(:), intent(out):: x
      integer ::i
      real :: xmult
      do i = 2,n
        xmult = a(i-1)/d(i-1)
        != stencil readOnce, backward(depth=1, dim=1, nonpointed) :: a, c
        != stencil readOnce, backward(depth=1, dim=1) :: d
        d(i) = d(i) - xmult*c(i-1)
        != stencil readOnce, backward(depth=1, dim=1, nonpointed) :: a
        != stencil readOnce, backward(depth=1, dim=1) :: b
        != stencil readOnce, backward(depth=1, dim=1, nonpointed) :: d
        b(i) = b(i) - xmult*b(i-1)
      end do
      x(n) = b(n)/d(n)
      do i = n-1,1,-1
        != stencil readOnce, pointed(dim=1) :: b, c, d
        != stencil readOnce, forward(depth=1, dim=1, nonpointed) :: x
        x(i) = (b(i) - c(i)*x(i+1))/d(i)
      end do
end subroutine tri


      SUBROUTINE MB04XD( JOBU, JOBV, M, N, RANK, THETA, A, LDA, U, LDU,
     $                   V, LDV, Q, INUL, TOL, RELTOL, DWORK, LDWORK,
     $                   IWARN, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute a basis for the left and/or right singular subspace of
C     an M-by-N matrix A corresponding to its smallest singular values.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOBU    CHARACTER*1
C             Specifies whether to compute the left singular subspace
C             as follows:
C             = 'N':  Do not compute the left singular subspace;
C             = 'A':  Return the (M - RANK) base vectors of the desired
C                     left singular subspace in U;
C             = 'S':  Return the first (min(M,N) - RANK) base vectors
C                     of the desired left singular subspace in U.
C
C     JOBV    CHARACTER*1
C             Specifies whether to compute the right singular subspace
C             as follows:
C             = 'N':  Do not compute the right singular subspace;
C             = 'A':  Return the (N - RANK) base vectors of the desired
C                     right singular subspace in V;
C             = 'S':  Return the first (min(M,N) - RANK) base vectors
C                     of the desired right singular subspace in V.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows in matrix A.  M >= 0.
C
C     N       (input) INTEGER
C             The number of columns in matrix A.  N >= 0.
C
C     RANK    (input/output) INTEGER
C             On entry, if RANK < 0, then the rank of matrix A is
C             computed by the routine as the number of singular values
C             greater than THETA.
C             Otherwise, RANK must specify the rank of matrix A.
C             RANK <= min(M,N).
C             On exit, if RANK < 0 on entry, then RANK contains the
C             computed rank of matrix A. That is, the number of singular
C             values of A greater than THETA.
C             Otherwise, the user-supplied value of RANK may be changed
C             by the routine on exit if the RANK-th and the (RANK+1)-th
C             singular values of A are considered to be equal.
C             See also the description of parameter TOL below.
C
C     THETA   (input/output) DOUBLE PRECISION
C             On entry, if RANK < 0, then THETA must specify an upper
C             bound on the smallest singular values of A corresponding
C             to the singular subspace to be computed.  THETA >= 0.0.
C             Otherwise, THETA must specify an initial estimate (t say)
C             for computing an upper bound on the (min(M,N) - RANK)
C             smallest singular values of A. If THETA < 0.0, then t is
C             computed by the routine.
C             On exit, if RANK >= 0 on entry, then THETA contains the
C             computed upper bound such that precisely RANK singular
C             values of A are greater than THETA + TOL.
C             Otherwise, THETA is unchanged.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading M-by-N part of this array must contain the
C             matrix A from which the basis of a desired singular
C             subspace is to be computed.
C             NOTE that this array is destroyed.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= max(1,M).
C
C     U       (output) DOUBLE PRECISION array, dimension (LDU,*)
C             If JOBU = 'A', then the leading M-by-M part of this array
C             contains the (M - RANK) M-dimensional base vectors of the
C             desired left singular subspace of A corresponding to its
C             singular values less than or equal to THETA. These vectors
C             are stored in the i-th column(s) of U for which
C             INUL(i) = .TRUE., where i = 1,2,...,M.
C
C             If JOBU = 'S', then the leading M-by-min(M,N) part of this
C             array contains the first (min(M,N) - RANK) M-dimensional
C             base vectors of the desired left singular subspace of A
C             corresponding to its singular values less than or equal to
C             THETA. These vectors are stored in the i-th column(s) of U
C             for which INUL(i) = .TRUE., where i = 1,2,..., min(M,N).
C
C             Otherwise, U is not referenced (since JOBU = 'N') and can
C             be supplied as a dummy array (i.e. set parameter LDU = 1
C             and declare this array to be U(1,1) in the calling
C             program).
C
C     LDU     INTEGER
C             The leading dimension of array U.
C             LDU >= max(1,M) if JOBU = 'A' or JOBU = 'S',
C             LDU >= 1        if JOBU = 'N'.
C
C     V       (output) DOUBLE PRECISION array, dimension (LDV,*)
C             If JOBV = 'A', then the leading N-by-N part of this array
C             contains the (N - RANK) N-dimensional base vectors of the
C             desired right singular subspace of A corresponding to its
C             singular values less than or equal to THETA. These vectors
C             are stored in the i-th column(s) of V for which
C             INUL(i) = .TRUE., where i = 1,2,...,N.
C
C             If JOBV = 'S', then the leading N-by-min(M,N) part of this
C             array contains the first (min(M,N) - RANK) N-dimensional
C             base vectors of the desired right singular subspace of A
C             corresponding to its singular values less than or equal to
C             THETA. These vectors are stored in the i-th column(s) of V
C             for which INUL(i) = .TRUE., where i = 1,2,...,MIN( M,N).
C
C             Otherwise, V is not referenced (since JOBV = 'N') and can
C             be supplied as a dummy array (i.e. set parameter LDV = 1
C             and declare this array to be V(1,1) in the calling
C             program).
C
C     LDV     INTEGER
C             The leading dimension of array V.
C             LDV >= max(1,N) if JOBV = 'A' or JOBV = 'S',
C             LDV >= 1        if JOBV = 'N'.
C
C     Q       (output) DOUBLE PRECISION array, dimension (2*min(M,N)-1)
C             This array contains the partially diagonalized bidiagonal
C             matrix J computed from A, at the moment that the desired
C             singular subspace has been found. Specifically, the
C             leading p = min(M,N) entries of Q contain the diagonal
C             elements q(1),q(2),...,q(p) and the entries Q(p+1),
C             Q(p+2),...,Q(2*p-1) contain the superdiagonal elements
C             e(1),e(2),...,e(p-1) of J.
C
C     INUL    (output) LOGICAL array, dimension (max(M,N))
C             If JOBU <> 'N' or JOBV <> 'N', then the indices of the
C             elements of this array with value .TRUE. indicate the
C             columns in U and/or V containing the base vectors of the
C             desired left and/or right singular subspace of A. They
C             also equal the indices of the diagonal elements of the
C             bidiagonal submatrices in the array Q, which correspond
C             to the computed singular subspaces.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             This parameter defines the multiplicity of singular values
C             by considering all singular values within an interval of
C             length TOL as coinciding. TOL is used in checking how many
C             singular values are less than or equal to THETA. Also in
C             computing an appropriate upper bound THETA by a bisection
C             method, TOL is used as a stopping criterion defining the
C             minimum (absolute) subinterval width. TOL is also taken
C             as an absolute tolerance for negligible elements in the
C             QR/QL iterations. If the user sets TOL to be less than or
C             equal to 0, then the tolerance is taken as specified in
C             SLICOT Library routine MB04YD document.
C
C     RELTOL  DOUBLE PRECISION
C             This parameter specifies the minimum relative width of an
C             interval. When an interval is narrower than TOL, or than
C             RELTOL times the larger (in magnitude) endpoint, then it
C             is considered to be sufficiently small and bisection has
C             converged. If the user sets RELTOL to be less than
C             BASE * EPS, where BASE is machine radix and EPS is machine
C             precision (see LAPACK Library routine DLAMCH), then the
C             tolerance is taken as BASE * EPS.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK = max(1, LDW + max(2*P + max(M,N), LDY)), where
C                  P = min(M,N);
C                LDW = max(2*N, N*(N+1)/2), if JOBU <> 'N' and M large
C                                                        enough than N;
C                LDW = 0,                   otherwise;
C                LDY = 8*P - 5, if JOBU <> 'N' or  JOBV <> 'N';
C                LDY = 6*P - 3, if JOBU =  'N' and JOBV =  'N'.
C             For optimum performance LDWORK should be larger.
C
C             If LDWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             DWORK array, returns this value as the first entry of
C             the DWORK array, and no error message related to LDWORK
C             is issued by XERBLA.
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             = 0:  no warning;
C             = 1:  if the rank of matrix A (as specified by the user)
C                   has been lowered because a singular value of
C                   multiplicity greater than 1 was found.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  if the maximum number of QR/QL iteration steps
C                   (30*MIN(M,N)) has been exceeded.
C
C     METHOD
C
C     The method used is the Partial Singular Value Decomposition (PSVD)
C     approach proposed by Van Huffel, Vandewalle and Haegemans, which
C     is an efficient technique (see [1]) for computing the singular
C     subspace of a matrix corresponding to its smallest singular
C     values. It differs from the classical SVD algorithm [3] at three
C     points, which results in high efficiency. Firstly, the Householder
C     transformations of the bidiagonalization need only to be applied
C     on the base vectors of the desired singular subspaces; secondly,
C     the bidiagonal matrix need only be partially diagonalized; and
C     thirdly, the convergence rate of the iterative diagonalization can
C     be improved by an appropriate choice between QL and QR iterations.
C     (Note, however, that LAPACK Library routine DGESVD, for computing
C     SVD, also uses either QL and QR iterations.) Depending on the gap,
C     the desired numerical accuracy and the dimension of the desired
C     singular subspace, the PSVD can be up to three times faster than
C     the classical SVD algorithm.
C
C     The PSVD algorithm [1-2] for an M-by-N matrix A proceeds as
C     follows:
C
C     Step 1: Bidiagonalization phase
C             -----------------------
C      (a) If M is large enough than N, transform A into upper
C          triangular form R.
C
C      (b) Transform A (or R) into bidiagonal form:
C
C                |q(1) e(1)  0   ...  0   |
C           (0)  | 0   q(2) e(2)      .   |
C          J   = | .                  .   |
C                | .                e(N-1)|
C                | 0            ...  q(N) |
C
C     if M >= N, or
C
C                |q(1)  0    0   ...  0     0   |
C           (0)  |e(1) q(2)  0        .     .   |
C          J   = | .                  .     .   |
C                | .                 q(M-1) .   |
C                | 0             ... e(M-1) q(M)|
C
C     if M < N, using Householder transformations.
C     In the second case, transform the matrix to the upper bidiagonal
C     form by applying Givens rotations.
C
C      (c) If U is requested, initialize U with the identity matrix.
C          If V is requested, initialize V with the identity matrix.
C
C     Step 2: Partial diagonalization phase
C             -----------------------------
C     If the upper bound THETA is not given, then compute THETA such
C     that precisely (min(M,N) - RANK) singular values of the bidiagonal
C     matrix are less than or equal to THETA, using a bisection method
C     [4]. Diagonalize the given bidiagonal matrix J partially, using
C     either QR iterations (if the upper left diagonal element of the
C     considered bidiagonal submatrix is larger than the lower right
C     diagonal element) or QL iterations, such that J is split into
C     unreduced bidiagonal submatrices whose singular values are either
C     all larger than THETA or all less than or equal to THETA.
C     Accumulate the Givens rotations in U and/or V (if desired).
C
C     Step 3: Back transformation phase
C             -------------------------
C      (a) Apply the Householder transformations of Step 1(b) onto the
C          columns of U and/or V associated with the bidiagonal
C          submatrices with all singular values less than or equal to
C          THETA (if U and/or V is desired).
C
C      (b) If M is large enough than N, and U is desired, then apply the
C          Householder transformations of Step 1(a) onto each computed
C          column of U in Step 3(a).
C
C     REFERENCES
C
C     [1] Van Huffel, S., Vandewalle, J. and Haegemans, A.
C         An efficient and reliable algorithm for computing the singular
C         subspace of a matrix associated with its smallest singular
C         values.
C         J. Comput. and Appl. Math., 19, pp. 313-330, 1987.
C
C     [2] Van Huffel, S.
C         Analysis of the total least squares problem and its use in
C         parameter estimation.
C         Doctoral dissertation, Dept. of Electr. Eng., Katholieke
C         Universiteit Leuven, Belgium, June 1987.
C
C     [3] Chan, T.F.
C         An improved algorithm for computing the singular value
C         decomposition.
C         ACM TOMS, 8, pp. 72-83, 1982.
C
C     [4] Van Huffel, S. and Vandewalle, J.
C         The partial total least squares algorithm.
C         J. Comput. and Appl. Math., 21, pp. 333-341, 1988.
C
C     NUMERICAL ASPECTS
C
C     Using the PSVD a large reduction in computation time can be
C     gained in total least squares applications (cf [2 - 4]), in the
C     computation of the null space of a matrix and in solving
C     (non)homogeneous linear equations.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1997.
C     Supersedes Release 2.0 routine MB04PD by S. Van Huffel, Katholieke
C     University Leuven, Belgium.
C
C     REVISIONS
C
C     V. Sima, July 10, 1997, Aug. 2011.
C
C     KEYWORDS
C
C     Bidiagonalization, singular subspace, singular value
C     decomposition, singular values.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         JOBU, JOBV
      INTEGER           INFO, IWARN, LDA, LDU, LDV, LDWORK, M, N, RANK
      DOUBLE PRECISION  RELTOL, THETA, TOL
C     .. Array Arguments ..
      LOGICAL           INUL(*)
      DOUBLE PRECISION  A(LDA,*), DWORK(*), Q(*), U(LDU,*), V(LDV,*)
C     .. Local Scalars ..
      CHARACTER*1       JOBUY, JOBVY
      LOGICAL           ALL, LJOBUA, LJOBUS, LJOBVA, LJOBVS, LQUERY, QR,
     $                  WANTU, WANTV
      INTEGER           I, IHOUSH, IJ, ITAU, ITAUP, ITAUQ, J, JU, JV,
     $                  JWORK, K, LDW, LDY, MA, MINWRK, P, PP1, WRKOPT
      DOUBLE PRECISION  CS, SN, TEMP
C     .. External Functions ..
      LOGICAL           LSAME
      INTEGER           ILAENV
      EXTERNAL          ILAENV, LSAME
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DGEBRD, DGEQRF, DLARTG, DLASET, DLASR,
     $                  MB04XY, MB04YD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         INT, MAX, MIN
C     .. Executable Statements ..
C
      IWARN = 0
      INFO  = 0
      P = MIN( M, N )
      K = MAX( M, N )
C
C     Determine whether U and/or V are/is to be computed.
C
      LJOBUA = LSAME( JOBU, 'A' )
      LJOBUS = LSAME( JOBU, 'S' )
      LJOBVA = LSAME( JOBV, 'A' )
      LJOBVS = LSAME( JOBV, 'S' )
      WANTU  = LJOBUA.OR.LJOBUS
      WANTV  = LJOBVA.OR.LJOBVS
      LQUERY = LDWORK.EQ.-1
C
C     Test the input scalar arguments.
C
      IF( .NOT.WANTU .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.WANTV .AND. .NOT.LSAME( JOBV, 'N' ) ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( RANK.GT.P ) THEN
         INFO = -5
      ELSE IF( RANK.LT.0 .AND. THETA.LT.ZERO ) THEN
         INFO = -6
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -8
      ELSE IF( ( .NOT.WANTU .AND. LDU.LT.1 )             .OR.
     $         (      WANTU .AND. LDU.LT.MAX( 1, M ) ) ) THEN
         INFO = -10
      ELSE IF( ( .NOT.WANTV .AND. LDV.LT.1 )             .OR.
     $         (      WANTV .AND. LDV.LT.MAX( 1, N ) ) ) THEN
         INFO = -12
      ELSE
C
C        Compute workspace.
C
         QR = M.GE.ILAENV( 6, 'DGESVD', 'N' // 'N', M, N, 0, 0 )
         IF ( QR.AND.WANTU ) THEN
            LDW = MAX( 2*N, N*( N + 1 )/2 )
         ELSE
            LDW = 0
         END IF
         IF ( WANTU.OR.WANTV ) THEN
            LDY = 8*P - 5
         ELSE
            LDY = 6*P - 3
         END IF
         MINWRK = MAX( 1, LDW + MAX( 2*P + K, LDY ) )
         IF( LDWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
            INFO = -18
         ELSE IF( LQUERY ) THEN
            IF ( QR ) THEN
               CALL DGEQRF( M, N, A, LDA, DWORK, DWORK, -1, INFO )
               WRKOPT = MAX( MINWRK, N + INT( DWORK(1) ) )
               MA = N
            ELSE
               WRKOPT = MINWRK
               MA = M
            END IF
            CALL DGEBRD( MA, N, A, LDA, Q, Q, DWORK, DWORK, DWORK, -1,
     $                   INFO )
            WRKOPT = MAX( WRKOPT, LDW + 2*P + INT( DWORK(1) ) )
         END IF
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB04XD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK(1) = WRKOPT
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( P.EQ.0 ) THEN
         IF ( RANK.GE.0 )
     $      THETA = ZERO
         RANK = 0
         RETURN
      END IF
C
C     Initializations.
C
      PP1 = P + 1
      ALL = ( LJOBUA .AND. M.GT.N ) .OR. ( LJOBVA .AND. M.LT.N )
C
      IF ( ALL .AND. ( .NOT.QR ) ) THEN
C
         DO 20 I = 1, P
            INUL(I) = .FALSE.
   20    CONTINUE
C
         DO 40 I = PP1, K
            INUL(I) = .TRUE.
   40    CONTINUE
C
      ELSE
C
         DO 60 I = 1, K
            INUL(I) = .FALSE.
   60    CONTINUE
C
      END IF
C
C     Step 1: Bidiagonalization phase
C             -----------------------
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of real workspace needed at that point in the
C     code, as well as the preferred amount for good performance.
C     NB refers to the optimal block size for the immediately
C     following subroutine, as returned by ILAENV.)
C
      IF ( QR ) THEN
C
C        1.a.: M is large enough than N; transform A into upper
C              triangular form R by Householder transformations.
C
C        Workspace: need 2*N;  prefer N + N*NB.
C
         ITAU = 1
         JWORK = ITAU + N
         CALL DGEQRF( M, N, A, LDA, DWORK(ITAU), DWORK(JWORK),
     $                LDWORK-JWORK+1, INFO )
         WRKOPT = INT( DWORK(JWORK) )+JWORK-1
C
C        If (WANTU), store information on the Householder
C        transformations performed on the columns of A in N*(N+1)/2
C        extra storage locations DWORK(K), for K = 1,2,...,N*(N+1)/2.
C        (The first N locations store the scalar factors of Householder
C        transformations.)
C
C        Workspace: LDW = max(2*N, N*(N+1)/2).
C
         IF ( WANTU ) THEN
            IHOUSH = JWORK
            K = IHOUSH
            I = N
         ELSE
            K = 1
         END IF
C
         DO 100 J = 1, N - 1
            IF ( WANTU ) THEN
               I = I - 1
               CALL DCOPY( I, A(J+1,J), 1, DWORK(K), 1 )
               K = K + I
            END IF
C
            DO 80 IJ = J + 1, N
               A(IJ,J) = ZERO
   80       CONTINUE
C
  100    CONTINUE
C
         MA = N
         WRKOPT = MAX( WRKOPT, K )
      ELSE
C
C        Workspace: LDW = 0.
C
         K  = 1
         MA = M
         WRKOPT = 1
      END IF
C
C     1.b.: Transform A (or R) into bidiagonal form Q using Householder
C           transformations.
C
C     Workspace: need   LDW + 2*min(M,N) + max(M,N);
C                prefer LDW + 2*min(M,N) + (M+N)*NB.
C
      ITAUQ = K
      ITAUP = ITAUQ + P
      JWORK = ITAUP + P
      CALL DGEBRD( MA, N, A, LDA, Q, Q(PP1), DWORK(ITAUQ),
     $             DWORK(ITAUP), DWORK(JWORK), LDWORK-JWORK+1, INFO )
      WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
C
C     1.c.: Initialize U (if WANTU) and V (if WANTV) with the identity
C           matrix.
C
      IF ( WANTU ) THEN
         IF ( ALL ) THEN
            JU = M
         ELSE
            JU = P
         END IF
         CALL DLASET( 'Full', M, JU, ZERO, ONE, U, LDU )
         JOBUY = 'U'
      ELSE
         JOBUY = 'N'
      END IF
      IF ( WANTV ) THEN
         IF ( ALL ) THEN
            JV = N
         ELSE
            JV = P
         END IF
         CALL DLASET( 'Full', N, JV, ZERO, ONE, V, LDV )
         JOBVY = 'U'
      ELSE
         JOBVY = 'N'
      END IF
C
C     If the matrix is lower bidiagonal, rotate to be upper bidiagonal
C     by applying Givens rotations on the left.
C
      IF ( M.LT.N ) THEN
C
         DO 120 I = 1, P - 1
            CALL DLARTG( Q(I), Q(P+I), CS, SN, TEMP )
            Q(I)   = TEMP
            Q(P+I) = SN*Q(I+1)
            Q(I+1) = CS*Q(I+1)
            IF ( WANTU ) THEN
C
C              Workspace: LDW + 4*min(M,N) - 2.
C
               DWORK(JWORK+I-1) = CS
               DWORK(JWORK+P+I-2) = SN
            END IF
  120    CONTINUE
C
C        Update left singular vectors if desired.
C
         IF( WANTU )
     $      CALL DLASR( 'Right', 'Variable pivot', 'Forward', M, JU,
     $                  DWORK(JWORK), DWORK(JWORK+P-1), U, LDU )
C
      END IF
C
C     Step 2: Partial diagonalization phase.
C             -----------------------------
C             Diagonalize the bidiagonal Q partially until convergence
C             to  the desired left and/or right singular subspace.
C
C              Workspace: LDW + 8*min(M,N) - 5, if WANTU or WANTV;
C              Workspace: LDW + 6*min(M,N) - 3, if JOBU = JOBV = 'N'.
C
      CALL MB04YD( JOBUY, JOBVY, M, N, RANK, THETA, Q, Q(PP1), U, LDU,
     $             V, LDV, INUL, TOL, RELTOL, DWORK(JWORK),
     $             LDWORK-JWORK+1, IWARN, INFO )
      IF ( WANTU.OR.WANTV ) THEN
         WRKOPT = MAX( WRKOPT, JWORK - 6 + 8*P )
      ELSE
         WRKOPT = MAX( WRKOPT, JWORK - 4 + 6*P )
      END IF
      IF ( INFO.GT.0 )
     $   RETURN
C
C     Step 3: Back transformation phase.
C             -------------------------
C     3.a.: Apply the Householder transformations of the bidiagonaliza-
C           tion onto the base vectors associated with the desired
C           bidiagonal submatrices.
C
C           Workspace: LDW + 2*min(M,N).
C
      CALL MB04XY( JOBU, JOBV, MA, N, A, LDA, DWORK(ITAUQ),
     $             DWORK(ITAUP), U, LDU, V, LDV, INUL, INFO )
C
C     3.b.: If A was reduced to upper triangular form R and JOBU = 'A'
C           or JOBU = 'S' apply the Householder transformations of the
C           triangularization of A onto the desired base vectors.
C
      IF ( QR.AND.WANTU ) THEN
         IF ( ALL ) THEN
C
            DO 140 I = PP1, M
               INUL(I) = .TRUE.
  140       CONTINUE
C
         END IF
         K = IHOUSH
         I = N
C
         DO 160 J = 1, N - 1
            I = I - 1
            CALL DCOPY( I, DWORK(K), 1, A(J+1,J), 1 )
            K = K + I
  160    CONTINUE
C
C        Workspace: MIN(M,N) + 1.
C
         JWORK = PP1
         CALL MB04XY( JOBU, 'No V', M, N, A, LDA, DWORK(ITAU),
     $                DWORK(ITAU), U, LDU, DWORK(JWORK), 1, INUL, INFO )
         WRKOPT = MAX( WRKOPT, PP1 )
      END IF
C
C     Set the optimal workspace.
C
      DWORK(1) = WRKOPT
      RETURN
C *** Last line of MB04XD ***
      END


C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C      Projet MICO - Newton Raphson (ver. FORTRAN 21.03.95)
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

C ----Declarations--------
      integer i, boucle, ii
      double precision h, a, b, Vh, Vv, E, Lh, Lv, compt
      double precision TOL, u
      double precision lambda
      double precision P(101), x(101), y(101), R(2), uu(2)
      double precision norm, F(2), Kt(2,2), Du(2), MAT(2)
      double precision invKt(2,2), dtmKt

C ----Donnees-------------
      h      = 40.
      a      = 24.
      b      = 40.
      Vh     = 160.
      Vv     = 200.
      E      = 70000.
      Lh     = 2*a
      Lv     = sqrt(h**2+(b+a)**2)
      TOL    = 1e-5
      i      = 0
      lambda = 0.
      uu(1)  = 0.
      uu(2)  = 0.
      R(1)   = 9000.
      R(2)   = 0.

C ----Boucle principale----

      do 10 compt=0,100
         i=i+1
         lambda=compt/100.
         boucle=0
         ii=0
20       u=uu(1)
         v=uu(2)
         ii=ii+1
         if (ii.GT.200) then
            boucle=1
         endif
         F(1)=(E*Vv/Lv**4)*(v*v+u*u-2*h*v+2*u*(a+b))*(v-h)
         F(2)=(Vv/Lv**4)*(v**2+u**2-2*h*v+2*u*(a+b))*(u+a+b)
         F(2)=F(2)+(8*Vh/Lh**4)*(u**2+2*a*u)*(u+a)
         if (lambda.NE.0) then
            norm=dsqrt((lambda*R(1)-F(1))**2+(lambda*R(2)-F(2))**2)
     *           /abs(lambda)/dsqrt(R(1)**2+R(2)**2)
C         write(*,*)norm
         else
            norm=0
         endif
         if (norm.GT.TOL) then
            Kt(1,1)=E*Vv/(Lv**4)*(2*u+2*(a+b))*(v-h)
            Kt(1,2)=E*Vv/(Lv**4)*((v**2+u**2-2*v*h+2*u*(a+b))
     *              +(v-h)*(2*v-2*h))
            Kt(2,1)=Vv/(Lv**4)*((v**2+u**2-2*h*v+2*u*(a+b))
     *              +(u+a+b)*(2*u+2*(a+b)))+8*Vh/(Lh**4)*((2*u+2*a)
     *              *(u+a)+(u**2+2*a*u))
            Kt(2,2)=Vv/(Lv**4)*(u+a+b)*(2*v-2*h)
            MAT(1)=lambda*R(1)-F(1)
            MAT(2)=lambda*R(2)-F(2)
            dtmKt=Kt(1,1)*Kt(2,2)-Kt(1,2)*Kt(2,1)
            invKt(1,1)=Kt(2,2)/dtmKt
            invKt(2,2)=Kt(1,1)/dtmKt
            invKt(1,2)=-1*Kt(1,2)/dtmKt
            invKt(2,1)=-1*Kt(2,1)/dtmKt
            Du(1)=invKt(1,1)*MAT(1)+invKt(1,2)*MAT(2)
            Du(2)=invKt(2,1)*MAT(1)+invKt(2,2)*MAT(2)
            uu(1)=uu(1)+Du(1)
            uu(2)=uu(2)+Du(2)
         else
            boucle=1
         endif
         if (boucle.EQ.0) goto 20
         x(i)=uu(2)
         y(i)=uu(1)
         P(i)=lambda*R(1)
10    continue

C ----Resultats-----------

32    open (UNIT = 1, FILE = 'nr_1.m', STATUS='unknown')
40    do 30 i=1,101
         write(1,*)'x(',i,')=',x(i),';'
         write(1,*)'y(',i,')=',y(i),';'
         write(1,*)'P(',i,')=',P(i),';'
30    continue
      write(1,*)'figure(1), plot(x,y), grid'
      write(1,*)'figure(2), plot(x,P), grid'
      close (UNIT=1)
      end


      SUBROUTINE PCC_POLY(NR,ICORE,AC,BC,CC,R,CDC)

ccccccccccccccccccccccccccccccccccccccccccc
cccccc   Replace the original full core charge CDC/r^2 inside r(icore),
cccccc   with a form (ac+bc*r^2+cc*r^3+dc*r^4), match the core charge
cccccc   for its value, slop, second and third derivatives.
cccccc   This is used for GGA calculation where the second derivative is needed
cccccc   The resulting core charge is smaller than the PCC_EXP.f result,
cccccc   and it guarentees that the third derivative is matched.
cccccc   Possible danger: there is no guarantee that the
cccccc   core charge is positive !! But usually, it does not happen.
cccccc
cccccc
ccccccccc  Lin-Wang Wang, Feb. 28, 2001

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      DIMENSION R(NR),CDC(NR)

cccccccccccccccccccccccccccccccccccccccccccc

            v0=cdc(icore)/r(icore)**2

            vp2=cdc(icore+2)/r(icore+2)**2
            vp1=cdc(icore+1)/r(icore+1)**2
            vm1=cdc(icore-1)/r(icore-1)**2
            vm2=cdc(icore-2)/r(icore-2)**2

            d0=(vp1-vm1)/(r(icore+1)-r(icore-1))
            v1=d0

            dp1h=(vp1-v0)/(r(icore+1)-r(icore))
            dp2h=(vp2-vp1)/(r(icore+2)-r(icore+1))
            dm1h=(v0-vm1)/(r(icore)-r(icore-1))
            dm2h=(vm1-vm2)/(r(icore-1)-r(icore-2))

            dd0=(dp1h-dm1h)/((r(icore+1)-r(icore-1))/2)
            v2=dd0

            ddp1=(dp2h-dp1h)/((r(icore+2)-r(icore))/2)
            ddm1=(dm1h-dm2h)/((r(icore)-r(icore-2))/2)

            ddd0=(ddp1-ddm1)/((r(icore+2)+2*r(icore+1)-
     &         r(icore-2)-2*r(icore-1))/4)
            v3=ddd0

            x=r(icore)

            dc=(x**2*v3-2*x*v2+2*v1)/(8*x**3)
            cc=(v3-24*dc*x)/6
            bc=(v2-12*dc*x**2-6*cc*x)/2
            ac=(v0-bc*x**2-cc*x**3-dc*x**4)

            do j=1,icore
            x=r(j)
            cdc(j)=x**2*(ac+bc*x**2+cc*x**3+dc*x**4)
            enddo

           return
           end


module euler
  integer, parameter :: huge = selected_int_kind(18)

contains

  function prime_factors(n) result(factors)
    implicit none
    integer(huge), intent(in) :: n
    integer, dimension(:), allocatable :: factors
    integer, dimension(:), allocatable :: updated_factors
    integer(huge) :: div, next, rest, i

    allocate(factors(1:0))

    i = 1

    div = 2

    next = 3

    rest = n

    do while (rest /= 1)
      do while (mod(rest, div) == 0)
        allocate(updated_factors(size(factors) + 1))

        updated_factors(1:size(factors)) = factors

        updated_factors(size(factors) + 1) = div

        deallocate(factors)

        allocate(factors(size(updated_factors)))

        factors = updated_factors

        deallocate(updated_factors)

        i = i + 1

        rest = rest / div
      enddo

      div = next

      next = next + 2
    enddo

    return
  end function prime_factors
end module euler

program main
  use euler
  implicit none
  integer, dimension(:), allocatable :: factors
  integer(huge) :: max, i

  factors = prime_factors(600851475143_huge)

  max = factors(1)

  do i = 1, size(factors)
    if (factors(i) > max) then
      max = factors(i)
    endif
  enddo

  write(*, '(i4)') max

  deallocate(factors)

  stop
end program main


      SUBROUTINE slS2TP (RA, DEC, RAZ, DECZ, XI, ETA, J)
*+
*     - - - - -
*      S 2 T P
*     - - - - -
*
*  Projection of spherical coordinates onto tangent plane:
*  "gnomonic" projection - "standard coordinates"
*  (single precision)
*
*  Given:
*     RA,DEC      real  spherical coordinates of point to be projected
*     RAZ,DECZ    real  spherical coordinates of tangent point
*
*  Returned:
*     XI,ETA      real  rectangular coordinates on tangent plane
*     J           int   status:   0 = OK, star on tangent plane
*                                 1 = error, star too far from axis
*                                 2 = error, antistar on tangent plane
*                                 3 = error, antistar too far from axis
*
*  P.T.Wallace   Starlink   18 July 1996
*
*  Copyright (C) 1996 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      REAL RA,DEC,RAZ,DECZ,XI,ETA
      INTEGER J

      REAL SDECZ,SDEC,CDECZ,CDEC,RADIF,SRADIF,CRADIF,DENOM

      REAL TINY
      PARAMETER (TINY=1E-6)

*  Trig functions
      SDECZ=SIN(DECZ)
      SDEC=SIN(DEC)
      CDECZ=COS(DECZ)
      CDEC=COS(DEC)
      RADIF=RA-RAZ
      SRADIF=SIN(RADIF)
      CRADIF=COS(RADIF)

*  Reciprocal of star vector length to tangent plane
      DENOM=SDEC*SDECZ+CDEC*CDECZ*CRADIF

*  Handle vectors too far from axis
      IF (DENOM.GT.TINY) THEN
         J=0
      ELSE IF (DENOM.GE.0.0) THEN
         J=1
         DENOM=TINY
      ELSE IF (DENOM.GT.-TINY) THEN
         J=2
         DENOM=-TINY
      ELSE
         J=3
      END IF

*  Compute tangent plane coordinates (even in dubious cases)
      XI=CDEC*SRADIF/DENOM
      ETA=(SDEC*CDECZ-CDEC*SDECZ*CRADIF)/DENOM

      END


module sampler

    implicit none
    integer, parameter :: dp = kind(1.d0)

contains

    real(dp) function rand_phi(uniform_rand)

        real(dp) :: uniform_rand
        real(dp), parameter :: pi = 4.d0*atan(1.d0)

        rand_phi = 2.d0 * pi * uniform_rand

    end function

    real(dp) function rand_cos_theta(uniform_rand)

        real(dp) :: uniform_rand

        rand_cos_theta = 2.d0 * uniform_rand - 1.d0

    end function

    integer function n_degen(n)

        integer :: n, l, d

        d = 0
        do l = 0,n-1
            d = d + 4*l + 2
        end do
        n_degen = d

    end function

    real(dp) function dist(r,Z,I)
        ! this function controls the distribution being sampled

        real(dp) :: r, I
        integer :: Z

!       dist = r**2*(exp(-2.d0*Z*r) + exp(-2*(r**2)*sqrt(2*I)))
        dist = r**2*exp((-2.d0*Z*r*(1+sqrt(2.d0*I)*r))/(1.d0+Z*r)) ! specifically the one discussed during the meeting

    end function

    real(dp) function norm_coeff(Z,I)
        ! Trapezoid integrator to find Z and I specific normalisation coefficient
        ! the integrand is asymptotic to 0 in the positive r direction so a suitable
        ! cutoff can be chosen

        real(dp) :: I, r1, r2, area, f1, f2, width
        real(dp), parameter :: cutoff_r = 100.d0
        integer :: Z, trpzd
        integer, parameter :: nr_trapezoids = 1000

        width = cutoff_r/nr_trapezoids

        area = 0.d0
        do trpzd = 1,nr_trapezoids
            r1 = (trpzd-1)*width
            r2 = trpzd*width
            f1 = dist(r1,Z,I)
            f2 = dist(r2,Z,I)
            area = area + width*(f1+f2)/2.d0
        end do

        norm_coeff = 1/area

    end function

    real(dp) function rand_r(Z,I,norm)
        ! Samples r using a von Neumann acceptance-rejection method

        real(dp) :: I, cutoff_radius, r, norm, max_r
        real(dp), dimension(2) :: rands
        integer :: Z, iter

        ! First need to find the maxvalue of dist(r,Z,I)
        max_r = 0.d0
        cutoff_radius = 5.d0
        do i = 1,1001
            r = dble((i-1))*cutoff_radius/1000.d0
            if (dist(r,Z,I) > dist(max_r,Z,I)) then
                max_r = r
            end if
        end do

        do
            call random_number(rands)
            r = rands(1)*cutoff_radius
!           if (cutoff_radius*rands(2) < dist(r,Z,I)*norm) then
            if (max_r*rands(2) < dist(r,Z,I)) then
                exit
            end if
        end do

        rand_r = r

    end function

    subroutine histogram(dist,dist_size,resolution,hist)

        integer, intent(in) :: dist_size
        integer, dimension(:), allocatable :: hist_count
        integer :: j, hist_elem, hist_size
        real(dp), dimension(dist_size), intent(in) :: dist
        real(dp), intent(in) :: resolution
        real(dp), dimension(:), allocatable, intent(out) :: hist

        hist_size = ceiling(maxval(dist)/resolution)
        allocate (hist_count(hist_size))
        hist_count(:) = 0

        do j = 1, dist_size
            hist_elem = ceiling(dist(j)/resolution)
            hist_count(hist_elem) = hist_count(hist_elem) + 1
        end do

        allocate (hist(hist_size))

        do j = 1, hist_size
            hist(j) = dble(hist_count(j)) / (dist_size*resolution)
        end do

        deallocate(hist_count)

    end subroutine

end module sampler

program ionspecificsampler

    use sampler

    implicit none
    integer :: ele, n_ele, Z_ion, j
    real(dp) :: phi, cos_theta, I, C, r, res
    real(dp), dimension(:,:), allocatable :: ele_dist_cartesian, ele_dist_spherical, angular_rand_nums
    real(dp), dimension(:), allocatable :: ele_dist_r, r_histogram

    n_ele = 100000
    Z_ion = 87
    I = 0.5d0

    C = norm_coeff(Z_ion,I)

    allocate (angular_rand_nums(2,n_ele))
    call random_number(angular_rand_nums)

    allocate (ele_dist_spherical(3,n_ele))
    allocate (ele_dist_r(n_ele))

    do ele = 1, n_ele
        phi = rand_phi(angular_rand_nums(1,ele))
        cos_theta = rand_cos_theta(angular_rand_nums(2,ele))
        r = rand_r(Z_ion,I,C)

!       print*, r, acos(cos_theta), phi

        ele_dist_r(ele) = r

        ele_dist_spherical(1,ele) = r
        ele_dist_spherical(2,ele) = acos(cos_theta)
        ele_dist_spherical(3,ele) = phi
    end do

    deallocate (angular_rand_nums)
    deallocate (ele_dist_spherical)

    res = 0.01d0
    call histogram(ele_dist_r(1), n_ele, res, r_histogram)

    deallocate (ele_dist_r)

    open (file="histogramdata", unit=8, status="replace")
        do j = 1,size(r_histogram)
            write (8,"(2f20.16)") (j - 0.5d0)*res, r_histogram(j)
        end do
    close (8)

    deallocate (r_histogram)

end program ionspecificsampler